1 /*
2 * Hash-Tables in CLISP
3 * Bruno Haible 1990-2005, 2016-2018
4 * Sam Steingold 1998-2011
5 * German comments translated into English: Stefan Kain 2002-01-29
6 */
7
8 #include "lispbibl.c"
9 #include "arilev0.c" /* for Hashcode-Calculation */
10 #include "aridecl.c" /* for Short-Floats */
11
12
13 /* Structure of a Hash-Table:
14 Pairs (Key . Value) are stored in a vector,
15 which is indexed by (hashcode Key).
16 For a running MAPHASH to be uninfluenced by a GC, this
17 vector is not reorganized because of GC. But as every (hashcode key) can
18 change on each GC, we build in an additional indexing-level:
19 (hashcode Key) indexes an index-vector; an index points into the
20 key-value-vector there, and the (key . value) is located there.
21 In order to save memory, we do not store a cons (key . value)
22 in the vector, but we simply store key and value consecutively.
23 One might want to resolve collisions [several keys have the same
24 (hascode Key)] with lists. Due to the fact that the key-value-vector
25 (again because of MAPHASH) should be uninfluenced on GC and GC changes
26 the set of collisions, we need an additional index-vector,
27 called the next-vector, which is interlaced with the key-value-vector
28 and which contains a "list"-structure.
29 sketch:
30 key --> (hashcode key) as index in index-vector.
31 Key1 --> 3, Key2 --> 1, Key4 --> 3.
32 index-vector #( nix {indexkey2} nix {indexkey1,indexkey4} nix ... )
33 = #( nix 1 nix 0 nix ... )
34 next-vector #( 3 nix leer nix leer)
35 key-value-vector #( key1 val1 3 key2 val2 nix leer leer leer key4 val4 nix leer leer leer)
36 access to a (Key . Value) - pair works as follows:
37 index := (aref Index-Vektor (hashcode Key))
38 until index = nix
39 if (eql Key (aref KVVektor 3*index)) return (aref KVVektor 3*index+1)
40 index := (aref Next-Vektor index) ; take "CDR" of the list
41 = (aref KVVektor 3*index+2)
42 return notfound.
43 If the index-vector is enlarged, all hashcodes and the content of
44 index-vector and the content of next-vector have to be recalculated.
45 If the next-vector and key-value-vector are enlarged, the remaining
46 elements can be filled with "leer" , without having to calculate
47 a new hashcode.
48 In order to have a fast MAPHASH following a CLRHASH or multiple REMHASH,
49 when the table contains much fewer elements than its capacity,
50 the entries could be kept "left-aligned" in the key-value-vector, i.e.
51 all "leer" go to the right. Thus, MAPHASH only needs to graze over the
52 elements count-1,...,1,0 of the key-value-vector. But REMHASH must
53 - after it has created a gap - copy the last key-value-pair
54 (Nummer count-1) into the gap.
55 We treat such cases by possibly shrinking the key-value-vector and
56 the next-vector on CLRHASH and REMHASH.
57 We keep the "leer"-entries in next-vector in a free-"list", so that PUTHASH
58 finds a free entry.
59 The lengths of index-vector and next-vector do not depend on each other.
60 We choose the ratio of their lengths to be 2:1.
61 The hash-table is enlarged, when the free-list is empty, i.e.
62 COUNT becomes greater than MAXCOUNT. Thereby, MAXCOUNT and SIZE are
63 multiplied by REHASH-SIZE (>1).
64 The hash-table is reduced, when COUNT < MINCOUNT. Thereby,
65 MAXCOUNT and SIZE are multiplied with 1/REHASH-SIZE (<1) . We choose
66 MINCOUNT = MAXCOUNT / REHASH-SIZE^2, so that COUNT can vary
67 in both directions by the same amount (on a logarithmic scale)
68 after the enlargement of the table.
69
70 data-structure of the hash-table (see LISPBIBL.D):
71 recflags codes the type and the state of the hash-table:
72 Bit 0..3 encode the test and the hash-code function
73 Bit 4..6 are state used to emit warnings for not GC-invariant keys
74 Bit 7 set, when table must be reorganized after GC
75 ht_size uintL>0 = length of the ITABLE
76 ht_maxcount Fixnum>0 = length of the NTABLE
77 ht_kvtable key-value-vector, a HashedAlist or WeakHashedAlist
78 with 3*MAXCOUNT data fields and
79 hal_itable index-vector of length SIZE
80 hal_count number of entries in the table, <=MAXCOUNT
81 hal_freelist start-index of the free-list
82 ht_rehash_size growth-rate on reorganization. Float >1.1
83 ht_mincount_threshold ratio MINCOUNT/MAXCOUNT = 1/rehash-size^2
84 ht_mincount Fixnum>=0, lower bound for COUNT
85 ht_test hash-table-test - for define-hash-table-test
86 ht_hash hash function - for define-hash-table-test
87 entry "leer" in key-value-vector is = #<UNBOUND>.
88 entry "leer" in next-vector is filled by the free-list.
89 entry "nix" in index-vector and in next-vector is = #<UNBOUND>. */
90 #define leer unbound
91 #define nix unbound
92
93 #define HT_GOOD_P(ht) \
94 (posfixnump(TheHashtable(ht)->ht_maxcount) && \
95 posfixnump(TheHashtable(ht)->ht_mincount))
96
97 /* ============================ Hash functions ============================ */
98
99 /* Rotates a hashcode x by n bits to the left (0<n<32).
100 rotate_left(n,x) */
101 #define rotate_left(n,x) (((x) << (n)) | ((x) >> (32-(n))))
102
103 /* mixes two hashcodes.
104 one is rotated by 5 bits, then the other one is XOR-ed to it. */
105 #define misch(x1,x2) (rotate_left(5,x1) ^ (x2))
106
107 /* ------------------------------ FASTHASH EQ ------------------------------ */
108
109 /* UP: Calculates the FASTHASH-EQ-hashcode of an object.
110 hashcode1(obj)
111 It is valid only until the next GC.
112 (eq X Y) implies (= (hashcode1 X) (hashcode1 Y)).
113 > obj: an object
114 < result: hashcode, a 32-Bit-number */
115 local uint32 hashcode1 (object obj);
116 #if (defined(WIDE_HARD) || defined(WIDE_SOFT)) && defined(TYPECODES)
117 #define hashcode1(obj) ((uint32)untype(obj))
118 #else
119 #define hashcode1(obj) ((uint32)as_oint(obj)) /* address (Bits 23..0) and typeinfo */
120 #endif
121
122 /* Tests whether hashcode1 of an object is guaranteed to be GC-invariant. */
gcinvariant_hashcode1_p(object obj)123 global bool gcinvariant_hashcode1_p (object obj) {
124 return gcinvariant_object_p(obj);
125 }
126
127 /* ----------------------------- STABLEHASH EQ ----------------------------- */
128
129 /* UP: Calculates the STABLEHASH-EQ-hashcode of an object.
130 hashcode1stable(obj)
131 It is valid across GC for instances of STANDARD-STABLEHASH, STRUCTURE-STABLEHASH.
132 (eq X Y) implies (= (hashcode1 X) (hashcode1 Y)).
133 > obj: an object
134 < result: hashcode, a 32-Bit-number */
hashcode1stable(object obj)135 global uint32 hashcode1stable (object obj) {
136 if (instancep(obj)) {
137 var object obj_forwarded = obj;
138 instance_un_realloc(obj_forwarded);
139 /* No need for instance_update here; if someone redefines a class in
140 such a way that the hashcode slot goes away, the behaviour is
141 undefined. */
142 var object cv = TheInstance(obj_forwarded)->inst_class_version;
143 var object clas = TheClassVersion(cv)->cv_class;
144 if (!nullp(TheClass(clas)->subclass_of_stablehash_p)) {
145 /* The hashcode slot is known to be at position 1, thanks to
146 :FIXED-SLOT-LOCATIONS. */
147 return posfixnum_to_V(TheInstance(obj_forwarded)->other[0]);
148 }
149 } else if (structurep(obj)) {
150 if (!nullp(memq(S(structure_stablehash),TheStructure(obj)->structure_types))) {
151 /* The hashcode slot is known to be at position 1, thanks to the way
152 slots are inherited in DEFSTRUCT. */
153 return posfixnum_to_V(TheStructure(obj)->recdata[1]);
154 }
155 } else if (symbolp(obj)) {
156 var object hashcode = TheSymbol(obj)->hashcode;
157 if (eq(hashcode,unbound)) {
158 /* The first access to a symbol's hash code computes it. */
159 pushSTACK(unbound); C_random_posfixnum(); hashcode = value1;
160 TheSymbol(obj)->hashcode = hashcode;
161 }
162 return posfixnum_to_V(hashcode);
163 }
164 return hashcode1(obj);
165 }
166
167 /* UP: Tests whether an object is instance of STANDARD-STABLEHASH or
168 STRUCTURE-STABLEHASH. */
instance_of_stablehash_p(object obj)169 local inline bool instance_of_stablehash_p (object obj) {
170 if (instancep(obj)) {
171 var object obj_forwarded = obj;
172 instance_un_realloc(obj_forwarded);
173 var object cv = TheInstance(obj_forwarded)->inst_class_version;
174 var object clas = TheClassVersion(cv)->cv_class;
175 return !nullp(TheClass(clas)->subclass_of_stablehash_p);
176 } else if (structurep(obj)) {
177 return !nullp(memq(S(structure_stablehash),TheStructure(obj)->structure_types));
178 }
179 return false;
180 }
181
182 /* Tests whether hashcode1stable of an object is guaranteed to be
183 GC-invariant. */
gcinvariant_hashcode1stable_p(object obj)184 global bool gcinvariant_hashcode1stable_p (object obj) {
185 return gcinvariant_object_p(obj)
186 || instance_of_stablehash_p(obj) || symbolp(obj);
187 }
188
189 /* ----------------------------- FASTHASH EQL ----------------------------- */
190
191 /* UP: Calculates the FASTHASH-EQL-hashcode of an object.
192 hashcode2(obj)
193 It is valid only until the next GC.
194 (eql X Y) implies (= (hashcode2 X) (hashcode2 Y)).
195 > obj: an object
196 < result: hashcode, a 32-Bit-number */
197 global uint32 hashcode2 (object obj);
198 /* auxiliary functions for known type:
199 Fixnum: fixnum-value */
200 local uint32 hashcode_fixnum (object obj);
201 #if 0
202 local uint32 hashcode_fixnum(object obj) { return hashcode1(obj); }
203 #else
204 #define hashcode_fixnum(obj) hashcode1(obj)
205 #endif
206 /* Bignum: length*2 + all digits */
hashcode_bignum(object obj)207 local uint32 hashcode_bignum (object obj) {
208 var uintL len = (uintL)Bignum_length(obj); /* number of Words */
209 var uint32 code = 2*len;
210 var uintL pos;
211 #if (intDsize==32)
212 for (pos=0; pos<len; pos++)
213 code = misch(code,TheBignum(obj)->data[pos]);
214 #elif (intDsize==16)
215 var uintL len1 = len & 1; /* len mod 2 */
216 var uintL len2 = len - len1; /* len div 2 */
217 for (pos=0; pos<len2; pos+=2)
218 code = misch(code,highlow32(TheBignum(obj)->data[pos],
219 TheBignum(obj)->data[pos+1]));
220 if (len1 != 0) code = misch(code,TheBignum(obj)->data[len2]); /* LSD */
221 #endif
222 return code;
223 }
224 /* Short-Float: internal representation */
225 local uint32 hashcode_sfloat (object obj);
226 #if 0
227 local uint32 hashcode_sfloat(object obj) { return hashcode1(obj); }
228 #else
229 #define hashcode_sfloat(obj) hashcode1(obj)
230 #endif
231 /* Single-Float: 32 Bit */
hashcode_ffloat(object obj)232 local uint32 hashcode_ffloat (object obj) {
233 return ffloat_value(obj);
234 }
235 /* Double-Float: leading 32 Bits */
hashcode_dfloat(object obj)236 local uint32 hashcode_dfloat (object obj) {
237 #ifdef intQsize
238 return (uint32)(TheDfloat(obj)->float_value >> 32);
239 #else
240 return TheDfloat(obj)->float_value.semhi;
241 #endif
242 }
243 /* Long-Float: mixture of exponent, length, first 32 bits */
244 extern uint32 hashcode_lfloat (object obj); /* see LFLOAT.D */
245 /* in general: */
hashcode2(object obj)246 global uint32 hashcode2 (object obj) {
247 #ifdef TYPECODES
248 if (!numberp(obj)) { /* a number? */
249 /* no -> take EQ-hashcode (for characters, EQL == EQ) : */
250 return hashcode1(obj);
251 } else { /* yes -> differentiate according to typecode */
252 switch (typecode(obj) & ~(bit(number_bit_t)|bit(sign_bit_t))) {
253 case fixnum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Fixnum */
254 return hashcode_fixnum(obj);
255 case bignum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Bignum */
256 return hashcode_bignum(obj);
257 case sfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Short-Float*/
258 return hashcode_sfloat(obj);
259 case ffloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Single-Float*/
260 return hashcode_ffloat(obj);
261 case dfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Double-Float*/
262 return hashcode_dfloat(obj);
263 case lfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Long-Float */
264 return hashcode_lfloat(obj);
265 case ratio_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Ratio */
266 /* hash both components, mix */
267 var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
268 var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
269 return misch(code1,code2);
270 }
271 case complex_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Complex */
272 /* hash both components, mix */
273 var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
274 var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
275 return misch(code1,code2);
276 }
277 default: NOTREACHED;
278 }
279 }
280 #else
281 if (orecordp(obj))
282 switch (Record_type(obj)) {
283 case Rectype_Bignum:
284 return hashcode_bignum(obj);
285 case Rectype_Ffloat:
286 return hashcode_ffloat(obj);
287 case Rectype_Dfloat:
288 return hashcode_dfloat(obj);
289 case Rectype_Lfloat:
290 return hashcode_lfloat(obj);
291 case Rectype_Ratio: { /* hash both components, mix */
292 var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
293 var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
294 return misch(code1,code2);
295 }
296 case Rectype_Complex: { /* hash both components, mix */
297 var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
298 var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
299 return misch(code1,code2);
300 }
301 default:
302 break;
303 }
304 else if (immediate_number_p(obj)) {
305 if (as_oint(obj) & wbit(4))
306 return hashcode_sfloat(obj);
307 else
308 return hashcode_fixnum(obj);
309 }
310 return hashcode1(obj);
311 #endif
312 }
313
314 /* Tests whether hashcode2 of an object is guaranteed to be GC-invariant. */
gcinvariant_hashcode2_p(object obj)315 global bool gcinvariant_hashcode2_p (object obj) {
316 return numberp(obj) || gcinvariant_object_p(obj);
317 }
318
319 /* ---------------------------- STABLEHASH EQL ---------------------------- */
320
321 /* UP: Calculates the STABLEHASH-EQL-hashcode of an object.
322 hashcode2stable(obj)
323 It is valid across GC for instances of STANDARD-STABLEHASH, STRUCTURE-STABLEHASH.
324 (eql X Y) implies (= (hashcode2stable X) (hashcode2stable Y)).
325 > obj: an object
326 < result: hashcode, a 32-Bit-number */
hashcode2stable(object obj)327 global uint32 hashcode2stable (object obj) {
328 #ifdef TYPECODES
329 if (!numberp(obj)) { /* a number? */
330 /* no -> take EQ-hashcode (for characters, EQL == EQ) : */
331 return hashcode1stable(obj);
332 } else { /* yes -> differentiate according to typecode */
333 switch (typecode(obj) & ~(bit(number_bit_t)|bit(sign_bit_t))) {
334 case fixnum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Fixnum */
335 return hashcode_fixnum(obj);
336 case bignum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Bignum */
337 return hashcode_bignum(obj);
338 case sfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Short-Float*/
339 return hashcode_sfloat(obj);
340 case ffloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Single-Float*/
341 return hashcode_ffloat(obj);
342 case dfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Double-Float*/
343 return hashcode_dfloat(obj);
344 case lfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Long-Float */
345 return hashcode_lfloat(obj);
346 case ratio_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Ratio */
347 /* hash both components, mix */
348 var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
349 var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
350 return misch(code1,code2);
351 }
352 case complex_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Complex */
353 /* hash both components, mix */
354 var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
355 var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
356 return misch(code1,code2);
357 }
358 default: NOTREACHED;
359 }
360 }
361 #else
362 if (orecordp(obj))
363 switch (Record_type(obj)) {
364 case Rectype_Bignum:
365 return hashcode_bignum(obj);
366 case Rectype_Ffloat:
367 return hashcode_ffloat(obj);
368 case Rectype_Dfloat:
369 return hashcode_dfloat(obj);
370 case Rectype_Lfloat:
371 return hashcode_lfloat(obj);
372 case Rectype_Ratio: { /* hash both components, mix */
373 var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
374 var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
375 return misch(code1,code2);
376 }
377 case Rectype_Complex: { /* hash both components, mix */
378 var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
379 var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
380 return misch(code1,code2);
381 }
382 default:
383 break;
384 }
385 else if (immediate_number_p(obj)) {
386 if (as_oint(obj) & wbit(4))
387 return hashcode_sfloat(obj);
388 else
389 return hashcode_fixnum(obj);
390 }
391 return hashcode1stable(obj);
392 #endif
393 }
394
395 /* Tests whether hashcode2stable of an object is guaranteed to be
396 GC-invariant. */
gcinvariant_hashcode2stable_p(object obj)397 global bool gcinvariant_hashcode2stable_p (object obj) {
398 return numberp(obj)
399 || gcinvariant_object_p(obj)
400 || instance_of_stablehash_p(obj) || symbolp(obj);
401 }
402
403 /* ---------------------------- FASTHASH EQUAL ---------------------------- */
404
405 /* UP: Calculates the FASTHASH-EQUAL-hashcode of an object.
406 hashcode3(obj)
407 It is valid only until the next GC, or the next modification
408 of the object.
409 (equal X Y) implies (= (hashcode3 X) (hashcode3 Y)).
410 > obj: an object
411 < result: hashcode, a 32-Bit-number */
412 global uint32 hashcode3 (object obj);
413 /* auxiliary functions for known type:
414 String -> length + all characters */
hashcode_string(object obj)415 local uint32 hashcode_string (object obj) {
416 var uintL len;
417 var uintL offset;
418 var object string = unpack_string_ro(obj,&len,&offset);
419 var uint32 bish_code = 0x33DAE11FUL + len; /* utilize length */
420 if (len > 0 && !simple_nilarray_p(string)) {
421 SstringDispatch(string,X, {
422 var const cintX* ptr = &((SstringX)TheVarobject(string))->data[offset];
423 var uintC count = len;
424 dotimespC(count,count, {
425 var uint32 next_code = (uint32)(*ptr++); /* next character */
426 bish_code = misch(bish_code,next_code); /* add */
427 });
428 });
429 }
430 return bish_code;
431 }
432 /* bit-vector -> length, first 16 bits, utilize last 16 bits */
hashcode_bvector(object obj)433 local uint32 hashcode_bvector (object obj) {
434 var uintL len = vector_length(obj); /* length */
435 var uintL index = 0;
436 var object sbv = array_displace_check(obj,len,&index);
437 /* sbv is the data-vector, index is the index into the data-vector. */
438 len = len << sbNvector_atype(sbv);
439 #if BIG_ENDIAN_P && (varobject_alignment%2 == 0)
440 /* On big-endian-machines one can work with with 16 Bit at a time
441 (so long as varobject_alignment is divisible by 2 byte): */
442 #define bitpack 16
443 #define uint_bitpack uint16
444 #define get32bits_at highlow32_at
445 #else
446 /* else one can take only 8 bit at a time: */
447 #define bitpack 8
448 #define uint_bitpack uint8
449 #define get32bits_at(p) \
450 (((((((uint32)((p)[0])<<8)|(uint32)((p)[1]))<<8)|(uint32)((p)[2]))<<8)|(uint32)((p)[3]))
451 #endif
452 var uint_bitpack* ptr = /* pointer to the first used word */
453 (uint_bitpack*)(&TheSbvector(sbv)->data[0]) + floor(index,bitpack);
454 var uintL offset = index%bitpack; /* offset within the word */
455 if (len <= 32) { /* length <= 32 -> take all bits: */
456 if (len == 0) {
457 return 0x8FA1D564UL;
458 } else { /* 0<len<=32 */
459 var uintL need = offset+len; /* need 'need' bits for now */
460 /* need < 48 */
461 var uint32 akku12 = 0; /* 48-Bit-Akku, part 1 and 2 */
462 var uint32 akku3 = 0; /* 48-Bit-Akku, part 3 */
463 #if (bitpack==16)
464 if (need > 0) {
465 akku12 = highlow32_0(*ptr++); /* first 16 bits */
466 if (need > 16) {
467 akku12 |= (uint32)(*ptr++); /* next 16 bits */
468 if (need > 32)
469 akku3 = (uint32)(*ptr++); /* last 16 bits */
470 }
471 }
472 #endif
473 #if (bitpack==8)
474 if (need > 0) {
475 akku12 = (uint32)(*ptr++)<<24; /* first 8 bits */
476 if (need > 8) {
477 akku12 |= (uint32)(*ptr++)<<16; /* next 8 bits */
478 if (need > 16) {
479 akku12 |= (uint32)(*ptr++)<<8; /* next 8 bits */
480 if (need > 24) {
481 akku12 |= (uint32)(*ptr++); /* next 8 bits */
482 if (need > 32) {
483 akku3 = (uint32)(*ptr++)<<8; /* next 8 bits */
484 if (need > 40)
485 akku3 |= (uint32)(*ptr++); /* last 8 bits */
486 }
487 }
488 }
489 }
490 }
491 #endif
492 /* shift 'need' bits in akku12,akku3 by offset bits to the left: */
493 akku12 = (akku12 << offset) | (uint32)high16(akku3 << offset);
494 /* 32 bits in akku12 finished.
495 mask out irrelevant bits: */
496 akku12 = akku12 & ~(bit(32-len)-1);
497 /* utilize length: */
498 return akku12+len;
499 }
500 } else { /* length > 32 -> take first and last 16 bits: */
501 var uint32 akku12 = /* 32-bit-akku */
502 get32bits_at(ptr) << offset; /* contains at least the first 16 bits */
503 offset += len; /* end-offset of the bitvector */
504 ptr += floor(offset,bitpack); /* points to the last used word */
505 offset = offset%bitpack; /* end-offset within the word */
506 var uint32 akku34 = /* 32-bit-akku */
507 get32bits_at(ptr-(16/bitpack)) << offset; /* contains at least the last 16 bits */
508 /* reach for the first 16, last 16 bits and utilize length: */
509 return highlow32(high16(akku12),high16(akku34)) + len;
510 }
511 #undef get32bits_at
512 #undef uint_bitpack
513 #undef bitpack
514 }
515 /* EQUALP-hashcode of a pathname-component. */
516 #ifdef PATHNAME_WIN32
517 global uint32 hashcode4 (object obj);
518 #define hashcode_pathcomp(obj) hashcode4(obj)
519 #else
520 #define hashcode_pathcomp(obj) hashcode3(obj)
521 #endif
hashcode_pathname(object obj)522 local uint32 hashcode_pathname (object obj) { /* obj is a pathname! */
523 check_SP();
524 var uint32 bish_code = 0xB0DD939EUL;
525 var const gcv_object_t* ptr = ((Record)ThePathname(obj))->recdata;
526 var uintC count = Xrecord_length(obj);
527 do {
528 var uint32 next_code = hashcode_pathcomp(*ptr++); /* hashcode of the next component */
529 bish_code = misch(bish_code,next_code); /* add */
530 } while (--count);
531 return bish_code;
532 }
533 #undef hashcode_pathcomp
534
535 /* atom -> differentiation by type */
hashcode3_atom(object obj,int level)536 local uint32 hashcode3_atom (object obj, int level) {
537 unused(level); /* recursion is possible only on conses, not HTs & arrays */
538 #ifdef TYPECODES
539 if (symbolp(obj)) { /* a symbol? */
540 return hashcode1(obj); /* yes -> take EQ-hashcode */
541 } else if (numberp(obj)) { /* a number? */
542 return hashcode2(obj); /* yes -> take EQL-hashcode */
543 } else {
544 var tint type = typecode(obj) /* typeinfo */
545 & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
546 if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
547 && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
548 return hashcode_bvector(obj); /* look at it component-wise */
549 if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
550 return hashcode_string(obj); /* look at it component-wise */
551 if (xpathnamep(obj)) /* look at it component-wise */
552 return hashcode_pathname(obj);
553 /* else: take EQ-hashcode (for characters: EQL == EQ) */
554 return hashcode1(obj);
555 }
556 #else
557 if (orecordp(obj))
558 switch (Record_type(obj)) {
559 case_Rectype_number_above;
560 case Rectype_Sbvector: case Rectype_bvector:
561 case Rectype_Sb2vector: case Rectype_b2vector:
562 case Rectype_Sb4vector: case Rectype_b4vector:
563 case Rectype_Sb8vector: case Rectype_b8vector:
564 case Rectype_Sb16vector: case Rectype_b16vector:
565 case Rectype_Sb32vector: case Rectype_b32vector:
566 return hashcode_bvector(obj);
567 case Rectype_S8string: case Rectype_Imm_S8string:
568 case Rectype_S16string: case Rectype_Imm_S16string:
569 case Rectype_S32string: case Rectype_Imm_S32string:
570 case Rectype_reallocstring: case Rectype_string:
571 return hashcode_string(obj);
572 case Rectype_Logpathname:
573 case Rectype_Pathname: /* look at it component-wise */
574 return hashcode_pathname(obj);
575 default:
576 break;
577 }
578 else if (immediate_number_p(obj)) {
579 case_number: return hashcode2(obj);
580 }
581 return hashcode1(obj);
582 #endif
583 }
584 /* tree -> look at content up to depth 4, more if some paths end early
585 determine the hashcode of the CAR and the hashcode of the CDR at a time
586 and combine them shifted. As shifts we can choose, e.g. 16,7,5,3, because
587 {0,16} + {0,7} + {0,5} + {0,3} = {0,3,5,7,8,10,12,15,16,19,21,23,24,26,28,31}
588 consists of 16 different elements of {0,...,31} .
589 > obj : the arbitrary object, tree(=cons) or leaf(=atom)
590 > need : how many objects are still needed
591 > level : the current distance from the root, to avoid circularity
592 > hashcode_atom : how to compute the hash code of a leaf */
593 #define HASHCODE_MAX_LEVEL 16
594 #define HASHCODE_NEED_LEAVES 16
hashcode_tree_rec(object obj,int * need,int level,uint32 (hashcode_leaf)(object,int))595 local inline uint32 hashcode_tree_rec (object obj, int* need, int level,
596 uint32 (hashcode_leaf) (object, int)) {
597 if (atomp(obj)) {
598 (*need)--;
599 return hashcode_leaf(obj,level+1);
600 } else if (level > HASHCODE_MAX_LEVEL || *need == 0) {
601 return 1;
602 } else {
603 var local const uint8 shifts[4] = { 16 , 7 , 5 , 3 };
604 var uint32 car_code =
605 hashcode_tree_rec(Car(obj),need,level+1,hashcode_leaf);
606 var uint32 cdr_code = *need == 0 ? 1 :
607 hashcode_tree_rec(Cdr(obj),need,level+1,hashcode_leaf);
608 return rotate_left(shifts[level & 3],car_code) ^ cdr_code;
609 }
610 }
hashcode_tree(object obj,int level,uint32 (hashcode_leaf)(object,int))611 local inline uint32 hashcode_tree (object obj, int level,
612 uint32 (hashcode_leaf) (object, int)) {
613 int need = HASHCODE_NEED_LEAVES;
614 return hashcode_tree_rec(obj,&need,level,hashcode_leaf);
615 }
616
617 /* similar to hashcode_tree
618 NB: use the SAME top-level need initial value (e.g., HASHCODE_NEED_LEAVES)
619 for the corresponding hashcode_tree and gcinvariant_hashcode_tree_p calls */
gcinvariant_hashcode_tree_p_rec(object obj,int * need,int level,bool (gcinvariant_hashcode_leaf_p)(object))620 local inline bool gcinvariant_hashcode_tree_p_rec
621 (object obj, int* need, int level,
622 bool (gcinvariant_hashcode_leaf_p) (object)) {
623 if (atomp(obj)) {
624 (*need)--;
625 return gcinvariant_hashcode_leaf_p(obj);
626 } else if (level > HASHCODE_MAX_LEVEL || *need == 0) {
627 return true;
628 } else {
629 return gcinvariant_hashcode_tree_p_rec(Car(obj),need,level+1,
630 gcinvariant_hashcode_leaf_p)
631 && (*need == 0 ? true :
632 gcinvariant_hashcode_tree_p_rec(Cdr(obj),need,level+1,
633 gcinvariant_hashcode_leaf_p));
634 }
635 }
gcinvariant_hashcode_tree_p(object obj,bool (gcinvariant_hashcode_leaf_p)(object))636 local inline bool gcinvariant_hashcode_tree_p
637 (object obj, bool (gcinvariant_hashcode_leaf_p) (object)) {
638 int need = HASHCODE_NEED_LEAVES;
639 return gcinvariant_hashcode_tree_p_rec(obj,&need,0,
640 gcinvariant_hashcode_leaf_p);
641 }
642
hashcode3(object obj)643 global uint32 hashcode3 (object obj)
644 { return hashcode_tree(obj,0,hashcode3_atom); }
645
646 /* Tests whether hashcode3 of an object is guaranteed to be GC-invariant. */
647 global bool gcinvariant_hashcode3_p (object obj);
gcinvariant_hashcode3_atom_p(object obj)648 local bool gcinvariant_hashcode3_atom_p (object obj) {
649 if (numberp(obj) || gcinvariant_object_p(obj))
650 return true;
651 #ifdef TYPECODES
652 var tint type = typecode(obj) /* typeinfo */
653 & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
654 if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
655 && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
656 return true;
657 if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
658 return true;
659 /* Ignore the pathnames, for simplicity. */
660 #else
661 if (orecordp(obj))
662 switch (Record_type(obj)) {
663 case Rectype_Sbvector: case Rectype_bvector:
664 case Rectype_Sb2vector: case Rectype_b2vector:
665 case Rectype_Sb4vector: case Rectype_b4vector:
666 case Rectype_Sb8vector: case Rectype_b8vector:
667 case Rectype_Sb16vector: case Rectype_b16vector:
668 case Rectype_Sb32vector: case Rectype_b32vector:
669 case Rectype_S8string: case Rectype_Imm_S8string:
670 case Rectype_S16string: case Rectype_Imm_S16string:
671 case Rectype_S32string: case Rectype_Imm_S32string:
672 case Rectype_reallocstring: case Rectype_string:
673 return true;
674 /* Ignore the pathnames, for simplicity. */
675 default:
676 break;
677 }
678 #endif
679 return false;
680 }
gcinvariant_hashcode3_p(object obj)681 global bool gcinvariant_hashcode3_p (object obj)
682 { return gcinvariant_hashcode_tree_p(obj,gcinvariant_hashcode3_atom_p); }
683
684 /* --------------------------- STABLEHASH EQUAL --------------------------- */
685
686 /* UP: Calculates the STABLEHASH-EQUAL-hashcode of an object.
687 hashcode3stable(obj)
688 It is valid across GC if all cons-tree leaves are instances of
689 STANDARD-STABLEHASH, STRUCTURE-STABLEHASH, but no longer than the next
690 modification of the object.
691 (equal X Y) implies (= (hashcode3stable X) (hashcode3stable Y)).
692 > obj: an object
693 < result: hashcode, a 32-Bit-number */
694 global uint32 hashcode3stable (object obj);
695 /* atom -> differentiation by type */
hashcode3stable_atom(object obj,int level)696 local uint32 hashcode3stable_atom (object obj, int level) {
697 unused(level); /* recursion is possible only on conses, not HTs & arrays */
698 #ifdef TYPECODES
699 if (symbolp(obj)) { /* a symbol? */
700 return hashcode1stable(obj); /* yes -> take EQ-hashcode */
701 } else if (numberp(obj)) { /* a number? */
702 return hashcode2(obj); /* yes -> take EQL-hashcode */
703 } else {
704 var tint type = typecode(obj) /* typeinfo */
705 & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
706 if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
707 && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
708 return hashcode_bvector(obj); /* look at it component-wise */
709 if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
710 return hashcode_string(obj); /* look at it component-wise */
711 if (xpathnamep(obj)) /* look at it component-wise */
712 return hashcode_pathname(obj);
713 /* else: take EQ-hashcode (for characters: EQL == EQ) */
714 return hashcode1stable(obj);
715 }
716 #else
717 if (orecordp(obj))
718 switch (Record_type(obj)) {
719 case_Rectype_number_above;
720 case Rectype_Sbvector: case Rectype_bvector:
721 case Rectype_Sb2vector: case Rectype_b2vector:
722 case Rectype_Sb4vector: case Rectype_b4vector:
723 case Rectype_Sb8vector: case Rectype_b8vector:
724 case Rectype_Sb16vector: case Rectype_b16vector:
725 case Rectype_Sb32vector: case Rectype_b32vector:
726 return hashcode_bvector(obj);
727 case Rectype_S8string: case Rectype_Imm_S8string:
728 case Rectype_S16string: case Rectype_Imm_S16string:
729 case Rectype_S32string: case Rectype_Imm_S32string:
730 case Rectype_reallocstring: case Rectype_string:
731 return hashcode_string(obj);
732 case Rectype_Logpathname:
733 case Rectype_Pathname: /* look at it component-wise */
734 return hashcode_pathname(obj);
735 default:
736 break;
737 }
738 else if (immediate_number_p(obj)) {
739 case_number: return hashcode2(obj);
740 }
741 return hashcode1stable(obj);
742 #endif
743 }
744
hashcode3stable(object obj)745 global uint32 hashcode3stable (object obj)
746 { return hashcode_tree(obj,0,hashcode3stable_atom); }
747
748 /* Tests whether hashcode3stable of an object is guaranteed to be
749 GC-invariant. */
750 global bool gcinvariant_hashcode3stable_p (object obj);
gcinvariant_hashcode3stable_atom_p(object obj)751 local bool gcinvariant_hashcode3stable_atom_p (object obj) {
752 if (numberp(obj) || gcinvariant_object_p(obj))
753 return true;
754 #ifdef TYPECODES
755 var tint type = typecode(obj) /* typeinfo */
756 & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
757 if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
758 && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
759 return true;
760 if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
761 return true;
762 /* Ignore the pathnames, for simplicity. */
763 #else
764 if (orecordp(obj))
765 switch (Record_type(obj)) {
766 case Rectype_Sbvector: case Rectype_bvector:
767 case Rectype_Sb2vector: case Rectype_b2vector:
768 case Rectype_Sb4vector: case Rectype_b4vector:
769 case Rectype_Sb8vector: case Rectype_b8vector:
770 case Rectype_Sb16vector: case Rectype_b16vector:
771 case Rectype_Sb32vector: case Rectype_b32vector:
772 case Rectype_S8string: case Rectype_Imm_S8string:
773 case Rectype_S16string: case Rectype_Imm_S16string:
774 case Rectype_S32string: case Rectype_Imm_S32string:
775 case Rectype_reallocstring: case Rectype_string:
776 return true;
777 /* Ignore the pathnames, for simplicity. */
778 default:
779 break;
780 }
781 #endif
782 return instance_of_stablehash_p(obj) || symbolp(obj);
783 }
gcinvariant_hashcode3stable_p(object obj)784 global bool gcinvariant_hashcode3stable_p (object obj)
785 { return gcinvariant_hashcode_tree_p(obj,gcinvariant_hashcode3stable_atom_p); }
786
787 /* ---------------------------- FASTHASH EQUALP ---------------------------- */
788
789 /* UP: Calculates the EQUALP-hashcode of an object.
790 hashcode4(obj)
791 Is is valid only until the next GC or the next modification
792 of the object.
793 (equalp X Y) implies (= (hashcode4 X) (hashcode4 Y)). */
794 global uint32 hashcode4 (object obj);
795 #define hashcode4_(obj) hashcode_tree(obj,level+1,hashcode4_atom);
796 /* auxiliary functions for known type:
797 character -> case-insensitive. */
798 #define hashcode4_char(c) (0xCAAEACEFUL + (uint32)as_cint(up_case(c)))
799 /* number: mixture of exponent, length, first 32 bit */
800 extern uint32 hashcode4_real (object obj); /* see REALELEM.D */
801 extern uint32 hashcode4_uint32 (uint32 x); /* see REALELEM.D */
802 extern uint32 hashcode4_uint4 [16]; /* see REALELEM.D */
803 local uint32 hashcode4_atom (object obj, int level);
804 /* vectors: look at them component-wise */
805 local uint32 hashcode4_vector_T (object dv, uintL index,
806 uintL count, uint32 bish_code, int level);
807 local uint32 hashcode4_vector_Char (object dv, uintL index,
808 uintL count, uint32 bish_code);
809 local uint32 hashcode4_vector_Bit (object dv, uintL index,
810 uintL count, uint32 bish_code);
811 local uint32 hashcode4_vector_2Bit (object dv, uintL index,
812 uintL count, uint32 bish_code);
813 local uint32 hashcode4_vector_4Bit (object dv, uintL index,
814 uintL count, uint32 bish_code);
815 local uint32 hashcode4_vector_8Bit (object dv, uintL index,
816 uintL count, uint32 bish_code);
817 local uint32 hashcode4_vector_16Bit (object dv, uintL index,
818 uintL count, uint32 bish_code);
819 local uint32 hashcode4_vector_32Bit (object dv, uintL index,
820 uintL count, uint32 bish_code);
821 local uint32 hashcode4_vector (object dv, uintL index,
822 uintL count, uint32 bish_code, int level);
hashcode4_vector_T(object dv,uintL index,uintL count,uint32 bish_code,int level)823 local uint32 hashcode4_vector_T (object dv, uintL index,
824 uintL count, uint32 bish_code, int level) {
825 if (count > 0) {
826 check_SP();
827 var const gcv_object_t* ptr = &TheSvector(dv)->data[index];
828 dotimespL(count,count, {
829 var uint32 next_code = hashcode4_(*ptr++); /* next component's hashcode */
830 bish_code = misch(bish_code,next_code); /* add */
831 });
832 }
833 return bish_code;
834 }
hashcode4_vector_Char(object dv,uintL index,uintL count,uint32 bish_code)835 local uint32 hashcode4_vector_Char (object dv, uintL index,
836 uintL count, uint32 bish_code) {
837 if (count > 0) {
838 SstringDispatch(dv,X, {
839 var const cintX* ptr = &((SstringX)TheVarobject(dv))->data[index];
840 dotimespL(count,count, {
841 var uint32 next_code = hashcode4_char(as_chart(*ptr++)); /*next char*/
842 bish_code = misch(bish_code,next_code); /* add */
843 });
844 });
845 }
846 return bish_code;
847 }
hashcode4_vector_Bit(object dv,uintL index,uintL count,uint32 bish_code)848 local uint32 hashcode4_vector_Bit (object dv, uintL index,
849 uintL count, uint32 bish_code) {
850 if (count > 0) {
851 var const uintB* ptr = &TheSbvector(dv)->data[index/8];
852 dotimespL(count,count, {
853 var uint32 next_code =
854 hashcode4_uint4[(*ptr >> ((~index)%8)) & (bit(1)-1)]; /* next byte */
855 bish_code = misch(bish_code,next_code); /* add */
856 index++;
857 ptr += ((index%8)==0);
858 });
859 }
860 return bish_code;
861 }
hashcode4_vector_2Bit(object dv,uintL index,uintL count,uint32 bish_code)862 local uint32 hashcode4_vector_2Bit (object dv, uintL index,
863 uintL count, uint32 bish_code) {
864 if (count > 0) {
865 var const uintB* ptr = &TheSbvector(dv)->data[index/4];
866 dotimespL(count,count, {
867 var uint32 next_code =
868 hashcode4_uint4[(*ptr >> ((~index)%4)) & (bit(2)-1)]; /* next byte */
869 bish_code = misch(bish_code,next_code); /* add */
870 index++;
871 ptr += ((index%4)==0);
872 });
873 }
874 return bish_code;
875 }
hashcode4_vector_4Bit(object dv,uintL index,uintL count,uint32 bish_code)876 local uint32 hashcode4_vector_4Bit (object dv, uintL index,
877 uintL count, uint32 bish_code) {
878 if (count > 0) {
879 var const uintB* ptr = &TheSbvector(dv)->data[index/2];
880 dotimespL(count,count, {
881 var uint32 next_code =
882 hashcode4_uint4[(*ptr >> ((~index)%2)) & (bit(4)-1)]; /* next byte */
883 bish_code = misch(bish_code,next_code); /* add */
884 index++;
885 ptr += ((index%2)==0);
886 });
887 }
888 return bish_code;
889 }
hashcode4_vector_8Bit(object dv,uintL index,uintL count,uint32 bish_code)890 local uint32 hashcode4_vector_8Bit (object dv, uintL index,
891 uintL count, uint32 bish_code) {
892 if (count > 0) {
893 var const uintB* ptr = &TheSbvector(dv)->data[index];
894 dotimespL(count,count, {
895 var uint32 next_code = hashcode4_uint32(*ptr++); /* next byte */
896 bish_code = misch(bish_code,next_code); /* add */
897 });
898 }
899 return bish_code;
900 }
hashcode4_vector_16Bit(object dv,uintL index,uintL count,uint32 bish_code)901 local uint32 hashcode4_vector_16Bit (object dv, uintL index,
902 uintL count, uint32 bish_code) {
903 if (count > 0) {
904 var const uint16* ptr = &((uint16*)&TheSbvector(dv)->data[0])[index];
905 dotimespL(count,count, {
906 var uint32 next_code = hashcode4_uint32(*ptr++); /* next byte */
907 bish_code = misch(bish_code,next_code); /* add */
908 });
909 }
910 return bish_code;
911 }
hashcode4_vector_32Bit(object dv,uintL index,uintL count,uint32 bish_code)912 local uint32 hashcode4_vector_32Bit (object dv, uintL index,
913 uintL count, uint32 bish_code) {
914 if (count > 0) {
915 var const uint32* ptr = &((uint32*)&TheSbvector(dv)->data[0])[index];
916 dotimespL(count,count, {
917 var uint32 next_code = hashcode4_uint32(*ptr++); /* next byte */
918 bish_code = misch(bish_code,next_code); /* add */
919 });
920 }
921 return bish_code;
922 }
hashcode4_vector(object dv,uintL index,uintL count,uint32 bish_code,int level)923 local uint32 hashcode4_vector (object dv, uintL index,
924 uintL count, uint32 bish_code, int level) {
925 if (count > HASHCODE_NEED_LEAVES) count = HASHCODE_NEED_LEAVES;
926 switch (Array_type(dv)) {
927 case Array_type_svector: /* simple-vector */
928 return hashcode4_vector_T(dv,index,count,bish_code,level);
929 case Array_type_sbvector: /* simple-bit-vector */
930 return hashcode4_vector_Bit(dv,index,count,bish_code);
931 case Array_type_sb2vector:
932 return hashcode4_vector_2Bit(dv,index,count,bish_code);
933 case Array_type_sb4vector:
934 return hashcode4_vector_4Bit(dv,index,count,bish_code);
935 case Array_type_sb8vector:
936 return hashcode4_vector_8Bit(dv,index,count,bish_code);
937 case Array_type_sb16vector:
938 return hashcode4_vector_16Bit(dv,index,count,bish_code);
939 case Array_type_sb32vector:
940 return hashcode4_vector_32Bit(dv,index,count,bish_code);
941 case Array_type_snilvector: /* (VECTOR NIL) */
942 if (count > 0)
943 return 0x2116ECD0 + bish_code;
944 /*FALLTHROUGH*/
945 case Array_type_sstring: /* simple-string */
946 return hashcode4_vector_Char(dv,index,count,bish_code);
947 default: NOTREACHED;
948 }
949 }
950 /* atom -> differentiation by type */
hashcode4_atom(object obj,int level)951 local uint32 hashcode4_atom (object obj, int level) {
952 #ifdef TYPECODES
953 if (symbolp(obj)) { /* a symbol? */
954 return hashcode1(obj); /* yes -> take EQ-hashcode */
955 } else if (numberp(obj)) { /* a number? */
956 /* yes -> take EQUALP-hashcode */
957 if (complexp(obj)) {
958 var uint32 code1 = hashcode4_real(TheComplex(obj)->c_real);
959 var uint32 code2 = hashcode4_real(TheComplex(obj)->c_imag);
960 /* important for combining, because of "complex canonicalization":
961 if imagpart=0.0, then hashcode = hashcode4_real(realpart). */
962 return code1 ^ rotate_left(5,code2);
963 } else {
964 return hashcode4_real(obj);
965 }
966 } else
967 switch (typecode(obj))
968 #else
969 if (orecordp(obj)) {
970 if (Record_type(obj) < rectype_longlimit)
971 goto case_orecord;
972 else
973 goto case_lrecord;
974 } else if (immediate_number_p(obj)) {
975 case_real: return hashcode4_real(obj);
976 } else if (charp(obj))
977 goto case_char;
978 else
979 return hashcode1(obj);
980 switch (0)
981 #endif
982 {
983 case_bvector: /* bit-vector */
984 case_b2vector: /* 2bit-vector */
985 case_b4vector: /* 4bit-vector */
986 case_b8vector: /* 8bit-vector */
987 case_b16vector: /* 16bit-vector */
988 case_b32vector: /* 32bit-vector */
989 case_string: /* string */
990 case_vector: { /* (VECTOR T), (VECTOR NIL) */
991 /* look at it component-wise: */
992 var uintL len = vector_length(obj); /* length */
993 var uint32 bish_code = 0x724BD24EUL + len; /* utilize length */
994 if (level <= HASHCODE_MAX_LEVEL) {
995 var uintL index = 0;
996 var object dv = array_displace_check(obj,len,&index);
997 /* dv is the data-vector, index is the index into the data-vector. */
998 return hashcode4_vector(dv,index,len,bish_code,level+1);
999 } else return bish_code;
1000 }
1001 case_mdarray: { /* array with rank /=1 */
1002 /* rank and dimensions, then look at it component-wise: */
1003 var uint32 bish_code = 0xF1C90A73UL;
1004 {
1005 var uintC rank = Iarray_rank(obj);
1006 if (rank > 0) {
1007 var uintL* dimptr = &TheIarray(obj)->dims[0];
1008 if (Iarray_flags(obj) & bit(arrayflags_dispoffset_bit))
1009 dimptr++;
1010 dotimespC(rank,rank, {
1011 var uint32 next_code = (uint32)(*dimptr++);
1012 bish_code = misch(bish_code,next_code);
1013 });
1014 }
1015 }
1016 if (level <= HASHCODE_MAX_LEVEL) {
1017 var uintL len = TheIarray(obj)->totalsize;
1018 var uintL index = 0;
1019 var object dv = iarray_displace_check(obj,len,&index);
1020 return hashcode4_vector(dv,index,len,bish_code,level+1);
1021 } else return bish_code;
1022 }
1023 #ifdef TYPECODES
1024 _case_structure
1025 _case_stream
1026 #endif
1027 case_orecord:
1028 switch (Record_type(obj)) {
1029 case_Rectype_bvector_above;
1030 case_Rectype_b2vector_above;
1031 case_Rectype_b4vector_above;
1032 case_Rectype_b8vector_above;
1033 case_Rectype_b16vector_above;
1034 case_Rectype_b32vector_above;
1035 case_Rectype_string_above;
1036 case_Rectype_vector_above;
1037 case_Rectype_mdarray_above;
1038 case_Rectype_Closure_above;
1039 case_Rectype_Instance_above;
1040 #ifndef TYPECODES
1041 case_Rectype_Symbol_above;
1042 case Rectype_Ratio:
1043 case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat:
1044 case Rectype_Bignum:
1045 goto case_real;
1046 case Rectype_Complex: {
1047 var uint32 code1 = hashcode4_real(TheComplex(obj)->c_real);
1048 var uint32 code2 = hashcode4_real(TheComplex(obj)->c_imag);
1049 /* important for combining, because of "complex canonicalization":
1050 if imagpart=0.0, then hashcode = hashcode4_real(realpart). */
1051 return code1 ^ rotate_left(5,code2);
1052 }
1053 #endif
1054 default: ;
1055 }
1056 { /* look at flags, type, components: */
1057 var uintC len = SXrecord_nonweak_length(obj);
1058 var uint32 bish_code =
1059 0x03168B8D + (Record_flags(obj) << 24) + (Record_type(obj) << 16) + len;
1060 if (level <= HASHCODE_MAX_LEVEL && len > 0) {
1061 check_SP();
1062 var const gcv_object_t* ptr = &TheRecord(obj)->recdata[0];
1063 var uintC count = len < HASHCODE_NEED_LEAVES
1064 ? len : HASHCODE_NEED_LEAVES; /* MIN(len,HASHCODE_NEED_LEAVES) */
1065 do {
1066 var uint32 next_code = hashcode4_(*ptr++); /* next component's hashcode */
1067 bish_code = misch(bish_code,next_code); /* add */
1068 } while (--count);
1069 }
1070 if (Record_type(obj) >= rectype_limit) {
1071 var uintC xlen = Xrecord_xlength(obj);
1072 if (xlen > 0) {
1073 var const uintB* ptr = (uintB*)&TheRecord(obj)->recdata[len];
1074 dotimespC(xlen,xlen, {
1075 var uint32 next_code = *ptr++; /* next byte */
1076 bish_code = misch(bish_code,next_code); /* add */
1077 });
1078 }
1079 }
1080 return bish_code;
1081 }
1082 case_char: /* character */
1083 return hashcode4_char(char_code(obj));
1084 #ifdef TYPECODES
1085 case_machine: /* machine */
1086 case_subr: /* subr */
1087 case_system: /* frame-pointer, small-read-label, system */
1088 #else
1089 case_symbol: /* symbol */
1090 #endif
1091 case_closure: /* closure */
1092 case_instance: /* instance */
1093 case_lrecord:
1094 /* take EQ-hashcode */
1095 return hashcode1(obj);
1096 default: NOTREACHED;
1097 }
1098 }
1099 #undef HASHCODE_MAX_LEVEL
1100 #undef HASHCODE_NEED_LEAVES
1101
hashcode4(object obj)1102 global uint32 hashcode4 (object obj)
1103 { return hashcode_tree(obj,0,hashcode4_atom); }
1104
1105 /* Tests whether hashcode4 of an object is guaranteed to be GC-invariant. */
1106 global bool gcinvariant_hashcode4_p (object obj);
gcinvariant_hashcode4_atom_p(object obj)1107 local bool gcinvariant_hashcode4_atom_p (object obj) {
1108 if (numberp(obj) || gcinvariant_object_p(obj))
1109 return true;
1110 #ifdef TYPECODES
1111 var tint type = typecode(obj) /* typeinfo */
1112 & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
1113 if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
1114 && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
1115 return true;
1116 if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
1117 return true;
1118 /* Ignore other types of arrays and records, for simplicity. */
1119 #else
1120 if (orecordp(obj))
1121 switch (Record_type(obj)) {
1122 case Rectype_Sbvector: case Rectype_bvector:
1123 case Rectype_Sb2vector: case Rectype_b2vector:
1124 case Rectype_Sb4vector: case Rectype_b4vector:
1125 case Rectype_Sb8vector: case Rectype_b8vector:
1126 case Rectype_Sb16vector: case Rectype_b16vector:
1127 case Rectype_Sb32vector: case Rectype_b32vector:
1128 case Rectype_S8string: case Rectype_Imm_S8string:
1129 case Rectype_S16string: case Rectype_Imm_S16string:
1130 case Rectype_S32string: case Rectype_Imm_S32string:
1131 case Rectype_reallocstring: case Rectype_string:
1132 return true;
1133 /* Ignore other types of arrays and records, for simplicity. */
1134 default:
1135 break;
1136 }
1137 #endif
1138 return false;
1139 }
gcinvariant_hashcode4_p(object obj)1140 global bool gcinvariant_hashcode4_p (object obj)
1141 { return gcinvariant_hashcode_tree_p(obj,gcinvariant_hashcode4_atom_p); }
1142
1143 /* ----------------------------- USER DEFINED ----------------------------- */
1144
1145 /* hashcode for user-defined ht_test */
hashcode_raw_user(object fun,object obj)1146 local uint32 hashcode_raw_user (object fun, object obj) {
1147 pushSTACK(obj); funcall(fun,1);
1148 value1 = check_uint32(value1);
1149 return I_to_UL(value1);
1150 }
1151
1152 /* =========================== Hash table record =========================== */
1153
1154 /* Specification of the flags in a hash-table: */
1155 #define htflags_test_builtin_B (bit(1)|bit(0)) /* for distinguishing builtin tests */
1156 #define htflags_test_eq_B ( 0 | 0 ) /* test is EQ */
1157 #define htflags_test_eql_B ( 0 |bit(0)) /* test is EQL */
1158 #define htflags_test_equal_B (bit(1)| 0 ) /* test is EQUAL */
1159 #define htflags_test_equalp_B (bit(1)|bit(0)) /* test is EQUALP */
1160 #define htflags_test_user_B bit(2) /* set for user-defined test */
1161 /* hash code of instances of STANDARD-STABLEHASH, STRUCTURE-STABLEHASH
1162 is GC-invariant */
1163 #define htflags_stablehash_B bit(3)
1164 /* Must call warn_forced_gc_rehash at the next opportunity */
1165 #define htflags_pending_warn_forced_gc_rehash bit(4)
1166 /* Warn when a key is being added whose hash code is not GC-invariant.
1167 - define htflags_warn_gc_rehash_B bit(5)
1168 Set after a key has been added whose hash code is not GC-invariant.
1169 - define htflags_gc_rehash_B bit(6)
1170 Set when the list structure is invalid and the table needs a rehash.
1171 - define htflags_invalid_B bit(7)
1172
1173 Specification of the two types of Pseudo-Functions:
1174
1175 Specification for LOOKUP - Pseudo-Function:
1176 lookup(ht,obj,allowgc,&KVptr,&Iptr)
1177 > ht: hash-table
1178 > obj: object
1179 > allowgc: whether GC is allowed during hash lookup
1180 < if found: result=true,
1181 KVptr[0], KVptr[1] : key, value in key-value-vector,
1182 KVptr[2] : index of next entry,
1183 *Iptr : previous index pointing to KVptr[0..2]
1184 < if not found: result=false,
1185 *Iptr : entry belonging to key in index-vector
1186 or an arbitrary element of the "list" starting there
1187 can trigger GC - if allowgc is true */
1188 typedef maygc bool (* lookup_Pseudofun) (object ht, object obj, bool allowgc, gcv_object_t** KVptr_, gcv_object_t** Iptr_);
1189
1190 /* Specification for HASHCODE - Pseudo-Function:
1191 hashcode(obj)
1192 > obj: object
1193 < result: its hash code */
1194 typedef uint32 (* hashcode_Pseudofun) (object obj);
1195
1196 /* Specification for TEST - Pseudo-Function:
1197 test(obj1,obj2)
1198 > obj1: object
1199 > obj2: object
1200 < result: true if they are considered equal */
1201 typedef bool (* test_Pseudofun) (object obj1, object obj2);
1202
1203 /* Specification for GCINVARIANT - Pseudo-Function:
1204 gcinvariant(obj)
1205 > obj: object
1206 < result: true if its hash code is guaranteed to be GC-invariant */
1207 typedef bool (* gcinvariant_Pseudofun) (object obj);
1208
1209 /* Extract Pseudo-Functions of a hash-table: */
1210 #define lookupfn(ht) \
1211 (*(lookup_Pseudofun)ThePseudofun(TheHashtable(ht)->ht_lookupfn))
1212 #define hashcodefn(ht) \
1213 (*(hashcode_Pseudofun)ThePseudofun(TheHashtable(ht)->ht_hashcodefn))
1214 #define testfn(ht) \
1215 (*(test_Pseudofun)ThePseudofun(TheHashtable(ht)->ht_testfn))
1216 #define gcinvariantfn(ht) \
1217 (*(gcinvariant_Pseudofun)ThePseudofun(TheHashtable(ht)->ht_gcinvariantfn))
1218
1219 /* UP: Calculates the hashcode of an object with reference to a hashtable.
1220 hashcode(ht,obj)
1221 > ht: hash-table
1222 > obj: object
1223 < result: index into the index-vector
1224 can trigger GC - for user-defined ht_test */
hashcode_raw(object ht,object obj)1225 local inline /*maygc*/ uintL hashcode_raw (object ht, object obj) {
1226 var uintB flags = record_flags(TheHashtable(ht));
1227 GCTRIGGER_IF(flags & htflags_test_user_B, GCTRIGGER2(ht,obj));
1228 return (flags & (htflags_test_builtin_B | htflags_stablehash_B)
1229 ? hashcodefn(ht)(obj) /* General built-in hash code */
1230 : !(flags & htflags_test_user_B)
1231 ? hashcode1(obj) /* FASTHASH-EQ hashcode */
1232 : hashcode_raw_user(TheHashtable(ht)->ht_hash,obj));
1233 }
hashcode_cook(uint32 code,uintL size)1234 local inline uintL hashcode_cook (uint32 code, uintL size) {
1235 /* divide raw hashcode CODE by SIZE: */
1236 var uint32 rest;
1237 divu_3232_3232(code,size,(void),rest=);
1238 return rest;
1239 }
hashcode(object ht,object obj)1240 local uintL hashcode (object ht, object obj) {
1241 var uintL size = TheHashtable(ht)->ht_size;
1242 return hashcode_cook(hashcode_raw(ht,obj),size);
1243 }
1244
1245 /* UP: Calculates the hashcode of an object with reference to a hashtable.
1246 hashcode_builtin(ht,obj)
1247 > ht: hash-table with built-in test
1248 > obj: object
1249 < result: index into the index-vector */
hashcode_builtin(object ht,object obj)1250 local inline uintL hashcode_builtin (object ht, object obj) {
1251 var uintL size = TheHashtable(ht)->ht_size;
1252 var uintB flags = record_flags(TheHashtable(ht));
1253 var uint32 coderaw =
1254 (flags & (htflags_test_builtin_B | htflags_stablehash_B)
1255 ? hashcodefn(ht)(obj) /* General built-in hash code */
1256 : hashcode1(obj)); /* FASTHASH-EQ hashcode */
1257 return hashcode_cook(coderaw,size);
1258 }
1259
1260 /* UP: Calculates the hashcode of an object with reference to a hashtable.
1261 hashcode_user(ht,obj)
1262 > ht: hash-table with user-defined test
1263 > obj: object
1264 < result: index into the index-vector
1265 can trigger GC */
hashcode_user(object ht,object obj)1266 local maygc uintL hashcode_user (object ht, object obj) {
1267 var uintL size = TheHashtable(ht)->ht_size;
1268 var uint32 coderaw = hashcode_raw_user(TheHashtable(ht)->ht_hash,obj);
1269 return hashcode_cook(coderaw,size);
1270 }
1271
1272 /* UP: Reorganizes a hash-table, after the hashcodes of the keys
1273 have been modified by a GC.
1274 rehash(ht);
1275 > ht: hash-table
1276 can trigger GC - for user-defined ht_test */
rehash(object ht)1277 local /*maygc*/ object rehash (object ht) {
1278 GCTRIGGER_IF(record_flags(TheHashtable(ht)) & htflags_test_user_B,
1279 GCTRIGGER1(ht));
1280 /* fill index-vector with "nix" : */
1281 var object kvtable = TheHashtable(ht)->ht_kvtable;
1282 var object Ivektor = TheHashedAlist(kvtable)->hal_itable; /* index-vector */
1283 {
1284 var gcv_object_t* ptr = &TheSvector(Ivektor)->data[0];
1285 var uintL count = TheHashtable(ht)->ht_size; /* SIZE, >0 */
1286 dotimespL(count,count, { *ptr++ = nix; } );
1287 }
1288 /* build up "list"-structure element-wise: */
1289 var object index = TheHashtable(ht)->ht_maxcount; /* MAXCOUNT */
1290 var uintL maxcount = posfixnum_to_V(index);
1291 var gcv_object_t* KVptr = &TheHashedAlist(kvtable)->hal_data[3*maxcount]; /* end of kvtable */
1292 var object freelist = nix;
1293 var object count = Fixnum_0;
1294 var bool user_defined_p =
1295 ht_test_code_user_p(ht_test_code(record_flags(TheHashtable(ht))));
1296 while (!eq(index,Fixnum_0)) { /* index=0 -> loop finished */
1297 /* traverse the key-value-vector and the next-vector.
1298 index = MAXCOUNT,...,0 (Fixnum),
1299 KVptr = &TheHashedAlist(kvtable)->hal_data[3*index],
1300 freelist = freelist up to now,
1301 count = pair-counter as fixnum. */
1302 index = fixnum_inc(index,-1); /* decrement index */
1303 KVptr -= 3;
1304 var object key = KVptr[0]; /* next key */
1305 if (!eq(key,leer)) { /* /= "leer" ? */
1306 if (user_defined_p)
1307 pushSTACK(ht); /* save */
1308 var uintL hashindex = hashcode(ht,key); /* its hashcode */
1309 if (user_defined_p) { /* restore - don't have to restore fixnums! */
1310 /* this implementation favors built-in ht-tests at the expense
1311 of the user-defined ones */
1312 ht = popSTACK();
1313 kvtable = TheHashtable(ht)->ht_kvtable;
1314 Ivektor = TheHashedAlist(kvtable)->hal_itable;
1315 KVptr = &TheHashedAlist(kvtable)->hal_data[3*posfixnum_to_V(index)];
1316 }
1317 /* "list", that starts at entry hashindex, in order to extend index:
1318 copy entry from index-vector to the next-vector
1319 end replace with index (a pointer to this location) : */
1320 var gcv_object_t* Iptr = &TheSvector(Ivektor)->data[hashindex];
1321 KVptr[2] = *Iptr; /* copy entry into the next-vector */
1322 *Iptr = index; /* and replace pointer to it */
1323 count = fixnum_inc(count,1); /* count */
1324 } else { /* lengthen freelist in the next-vector: */
1325 KVptr[2] = freelist; freelist = index;
1326 }
1327 }
1328 TheHashedAlist(kvtable)->hal_freelist = freelist; /* save freelist */
1329 TheHashedAlist(kvtable)->hal_count = count; /* save number of pairs for consistency */
1330 set_ht_valid(TheHashtable(ht)); /* hashtable is now completely organized */
1331 return ht;
1332 }
1333
1334 /* Warn if a hash table is rehashed because of a GC, degrading performance.
1335 can trigger GC */
warn_forced_gc_rehash(object ht)1336 local maygc void warn_forced_gc_rehash (object ht) {
1337 pushSTACK(NIL); pushSTACK(ht);
1338 STACK_1 = CLSTEXT("Performance/scalability warning: The hash table ~S needs "
1339 "to be rehashed after a garbage collection, since it "
1340 "contains key whose hash code is not GC-invariant.");
1341 funcall(S(warn),2);
1342 }
1343
1344 /* UP: Searches a key in a hash-table.
1345 hash_lookup_builtin(ht,obj,allowgc,&KVptr,&Iptr)
1346 > ht: hash-table
1347 > obj: object
1348 > allowgc: whether GC is allowed during hash lookup
1349 < if found: result=true,
1350 KVptr[0], KVptr[1] : key, value in key-value-vector,
1351 KVptr[2] : index of next entry,
1352 *Iptr : previous index pointing to KVptr[0..2]
1353 < if not found: result=false,
1354 *Iptr : entry belonging to key in index-vector
1355 or an arbitrary element of the "list" starting there
1356 can trigger GC - if allowgc is true */
hash_lookup_builtin(object ht,object obj,bool allowgc,gcv_object_t ** KVptr_,gcv_object_t ** Iptr_)1357 global /*maygc*/ bool hash_lookup_builtin (object ht, object obj, bool allowgc,
1358 gcv_object_t** KVptr_,
1359 gcv_object_t** Iptr_) {
1360 GCTRIGGER_IF(allowgc, GCTRIGGER2(ht,obj));
1361 #ifdef GENERATIONAL_GC
1362 if (!ht_validp(TheHashtable(ht))) { /* hash-table must be reorganized? */
1363 /* Rehash it before the warning, otherwise we risk an endless recursion. */
1364 ht = rehash(ht);
1365 /* Warn if *WARN-ON-HASHTABLE-NEEDING-REHASH-AFTER-GC* is true: */
1366 if (!nullpSv(warn_on_hashtable_needing_rehash_after_gc)) {
1367 if (allowgc) {
1368 record_flags_clr(TheHashtable(ht),htflags_pending_warn_forced_gc_rehash);
1369 pushSTACK(ht); pushSTACK(obj);
1370 warn_forced_gc_rehash(ht);
1371 obj = popSTACK(); ht = popSTACK();
1372 if (!ht_validp(TheHashtable(ht))) /* must be reorganized again? */
1373 ht = rehash(ht);
1374 } else {
1375 /* We cannot warn now, because in this call we are not allowed to
1376 trigger GC, therefore we delay the call until the next opportunity. */
1377 record_flags_set(TheHashtable(ht),htflags_pending_warn_forced_gc_rehash);
1378 }
1379 }
1380 }
1381 #endif
1382 if (allowgc
1383 && (record_flags(TheHashtable(ht)) & htflags_pending_warn_forced_gc_rehash)) {
1384 /* Now is an opportunity to get rid of the pending warn_forced_gc_rehash task. */
1385 record_flags_clr(TheHashtable(ht),htflags_pending_warn_forced_gc_rehash);
1386 pushSTACK(ht); pushSTACK(obj);
1387 warn_forced_gc_rehash(ht);
1388 obj = popSTACK(); ht = popSTACK();
1389 if (!ht_validp(TheHashtable(ht))) /* must be reorganized again? */
1390 ht = rehash(ht);
1391 }
1392 ASSERT(ht_validp(TheHashtable(ht)));
1393 var uintB flags = record_flags(TheHashtable(ht));
1394 var uintL hashindex = hashcode_builtin(ht,obj); /* calculate hashcode */
1395 var object kvtable = TheHashtable(ht)->ht_kvtable;
1396 var gcv_object_t* Nptr = /* pointer to the current entry */
1397 &TheSvector(TheHashedAlist(kvtable)->hal_itable)->data[hashindex];
1398 var gcv_object_t* kvt_data = TheHashedAlist(kvtable)->hal_data;
1399 while (!eq(*Nptr,nix)) { /* track "list" : "list" finished -> not found */
1400 var uintL index = posfixnum_to_V(*Nptr); /* next index */
1401 var gcv_object_t* Iptr = Nptr;
1402 var gcv_object_t* KVptr = /* pointer to entries in key-value-vector */
1403 kvt_data + 3*index;
1404 var object key = KVptr[0];
1405 /* compare key with obj: */
1406 if ((flags & htflags_test_builtin_B) == htflags_test_eq_B
1407 ? eq(key,obj) /* compare with EQ */
1408 : testfn(ht)(key,obj)) {
1409 /* object obj found */
1410 *KVptr_ = KVptr; *Iptr_ = Iptr; return true;
1411 }
1412 Nptr = &KVptr[2]; /* pointer to index of next entry */
1413 }
1414 /* not found */
1415 *Iptr_ = Nptr; return false;
1416 }
1417 #ifndef GENERATIONAL_GC
1418 /* can trigger GC - if allowgc is true */
hash_lookup_builtin_with_rehash(object ht,object obj,bool allowgc,gcv_object_t ** KVptr_,gcv_object_t ** Iptr_)1419 global /*maygc*/ bool hash_lookup_builtin_with_rehash (object ht, object obj, bool allowgc,
1420 gcv_object_t** KVptr_, gcv_object_t** Iptr_) {
1421 GCTRIGGER_IF(allowgc, GCTRIGGER2(ht,obj));
1422 if (!ht_validp(TheHashtable(ht))) { /* hash-table must be reorganized? */
1423 /* Rehash it before the warning, otherwise we risk an endless recursion. */
1424 ht = rehash(ht);
1425 /* Warn if *WARN-ON-HASHTABLE-NEEDING-REHASH-AFTER-GC* is true: */
1426 if (!nullpSv(warn_on_hashtable_needing_rehash_after_gc)) {
1427 if (allowgc) {
1428 record_flags_clr(TheHashtable(ht),htflags_pending_warn_forced_gc_rehash);
1429 pushSTACK(ht); pushSTACK(obj);
1430 warn_forced_gc_rehash(ht);
1431 obj = popSTACK(); ht = popSTACK();
1432 if (!ht_validp(TheHashtable(ht))) /* must be reorganized again? */
1433 ht = rehash(ht);
1434 } else {
1435 /* We cannot warn now, because in this call we are not allowed to
1436 trigger GC, therefore we delay the call until the next opportunity. */
1437 record_flags_set(TheHashtable(ht),htflags_pending_warn_forced_gc_rehash);
1438 }
1439 }
1440 }
1441 return hash_lookup_builtin(ht,obj,allowgc,KVptr_,Iptr_);
1442 }
1443 #endif
1444
1445 /* UP: Searches a key in a hash-table with user-defined test.
1446 hash_lookup_user(ht,obj,allowgc,&KVptr,&Iptr)
1447 > ht: hash-table
1448 > obj: object
1449 > allowgc: whether GC is allowed during hash lookup
1450 < if found: result=true,
1451 KVptr[0], KVptr[1] : key, value in key-value-vector,
1452 KVptr[2] : index of next entry,
1453 *Iptr : previous index pointing to KVptr[0..2]
1454 < if not found: result=false,
1455 *Iptr : entry belonging to key in index-vector
1456 or an arbitrary element of the "list" starting there
1457 can trigger GC - if allowgc is true */
hash_lookup_user(object ht,object obj,bool allowgc,gcv_object_t ** KVptr_,gcv_object_t ** Iptr_)1458 global maygc bool hash_lookup_user (object ht, object obj, bool allowgc,
1459 gcv_object_t** KVptr_, gcv_object_t** Iptr_)
1460 {
1461 ASSERT(allowgc);
1462 pushSTACK(ht); pushSTACK(obj);
1463 if (!ht_validp(TheHashtable(ht))) /* hash-table must be reorganized */
1464 ht = rehash(ht);
1465 obj = STACK_0; /* rehash could trigger GC */
1466 var uintL hashindex = hashcode_user(ht,obj); /* calculate hashcode */
1467 obj = popSTACK(); ht = popSTACK();
1468 var object kvtable = TheHashtable(ht)->ht_kvtable;
1469 var gcv_object_t* Nptr = /* pointer to the current entry */
1470 &TheSvector(TheHashedAlist(kvtable)->hal_itable)->data[hashindex];
1471 var gcv_object_t* kvt_data = TheHashedAlist(kvtable)->hal_data;
1472 var uintL i_n; /* Iptr-Nptr FIXME: This is not GC-safe */
1473 while (!eq(*Nptr,nix)) { /* track "list" : "list" finished -> not found */
1474 var uintL index = posfixnum_to_V(*Nptr); /* next index */
1475 var gcv_object_t* Iptr = Nptr;
1476 var gcv_object_t* KVptr = /* pointer to entries in key-value-vector */
1477 kvt_data + 3*index;
1478 Nptr = &KVptr[2]; /* pointer to index of next entry */
1479 /* compare key with obj: */
1480 pushSTACK(ht); pushSTACK(obj);
1481 i_n = Iptr - Nptr;
1482 pushSTACK(KVptr[0]); pushSTACK(obj); funcall(TheHashtable(ht)->ht_test,2);
1483 obj = popSTACK(); ht = popSTACK();
1484 kvtable = TheHashtable(ht)->ht_kvtable;
1485 kvt_data = TheHashedAlist(kvtable)->hal_data;
1486 KVptr = kvt_data + 3*index; Nptr = &KVptr[2];
1487 Iptr = Nptr + i_n;
1488 if (!nullp(value1)) {
1489 /* object obj found */
1490 *KVptr_ = KVptr; *Iptr_ = Iptr; return true;
1491 }
1492 }
1493 /* not found */
1494 *Iptr_ = Nptr; return false;
1495 }
1496
1497 /* UP: Searches a key in a hash-table.
1498 hash_lookup(ht,obj,allowgc,&KVptr,&Iptr)
1499 > ht: hash-table
1500 > obj: object
1501 > allowgc: whether GC is allowed during hash lookup
1502 < if found: result=true,
1503 KVptr[0], KVptr[1] : key, value in key-value-vector,
1504 KVptr[2] : index of next entry,
1505 *Iptr : previous index pointing to KVptr[0..2]
1506 < if not found: result=false,
1507 *Iptr : entry belonging to key in index-vector
1508 or an arbitrary element of the "list" starting there
1509 can trigger GC - if allowgc is true */
1510 #define hash_lookup(ht,obj,allowgc,KVptr_,Iptr_) \
1511 lookupfn(ht)(ht,obj,allowgc,KVptr_,Iptr_)
1512
1513 /* UP: Tests whether the hash code of a given key in a hash table is stable
1514 i.e. gc-invariant, or not.
1515 > ht: hash-table
1516 > obj: object
1517 < result: true if the key's hash code is gc-invariant */
hashcode_gc_invariant_p(object ht,object obj)1518 local inline bool hashcode_gc_invariant_p (object ht, object obj) {
1519 return gcinvariantfn(ht)(obj);
1520 }
1521
1522 /* Warn if adding an key to a hash table degrades its performance.
1523 can trigger GC */
warn_key_forces_gc_rehash(object ht,object key)1524 local maygc void warn_key_forces_gc_rehash (object ht, object key) {
1525 pushSTACK(NIL); pushSTACK(ht); pushSTACK(key);
1526 STACK_2 = CLSTEXT("Performance/scalability warning: The hash table ~S must "
1527 "be rehashed after each garbage collection, since its "
1528 "key ~S has a hash code that is not GC-invariant.");
1529 funcall(S(warn),3);
1530 }
1531
1532 /* Macro: Insers a key-value-pair into a hash-table.
1533 hash_store(key,value);
1534 > object ht: hash-table
1535 > object freelist: Start of the free-list in next-vector, /= nix
1536 > key: key
1537 > value: value
1538 > gcv_object_t* Iptr: arbitrary element of the "list", that belongs to key
1539 can trigger GC */
1540 #define hash_store(key,value) \
1541 do { \
1542 var uintL index = posfixnum_to_V(freelist); /* free index */ \
1543 var object kvtable = TheHashtable(ht)->ht_kvtable; \
1544 /* address of the free entries in key-value-vector: */ \
1545 var gcv_object_t* KVptr = &TheHashedAlist(kvtable)->hal_data[3*index]; \
1546 set_break_sem_2(); /* protect from breaks */ \
1547 /* increment COUNT: */ \
1548 TheHashedAlist(kvtable)->hal_count = fixnum_inc(TheHashedAlist(kvtable)->hal_count,1); \
1549 /* save key and value: */ \
1550 *KVptr++ = key; *KVptr++ = value; \
1551 /* shorten free-list: */ \
1552 TheHashedAlist(kvtable)->hal_freelist = *KVptr; \
1553 /* insert free list-element index into the "list" \
1554 (put it after resize to the list-start, \
1555 because Iptr points into the index-vector, \
1556 else put it to the list-end, \
1557 because hash_lookup was ended with *Iptr=nix): */ \
1558 *KVptr = *Iptr; *Iptr = freelist; \
1559 { /* Set the htflags_gc_rehash_B bit if necessary. */ \
1560 var bool this_key_forces_gc_rehash = false; \
1561 var uintB flags = record_flags(TheHashtable(ht)); \
1562 if (!(flags & htflags_test_user_B) && !(flags & htflags_gc_rehash_B)) \
1563 if (!hashcode_gc_invariant_p(ht,key)) { \
1564 record_flags_set(TheHashtable(ht),htflags_gc_rehash_B); \
1565 this_key_forces_gc_rehash = true; \
1566 } \
1567 clr_break_sem_2(); /* allow breaks again */ \
1568 if (this_key_forces_gc_rehash) \
1569 if (record_flags(TheHashtable(ht)) & htflags_warn_gc_rehash_B) \
1570 warn_key_forces_gc_rehash(ht,key); \
1571 } \
1572 } while(0)
1573
1574 /* hash_table_weak_type(ht)
1575 > ht: hash-table
1576 < result: symbol NIL/:KEY/:VALUE/:KEY-AND-VALUE/:KEY-OR-VALUE */
hash_table_weak_type(object ht)1577 global object hash_table_weak_type (object ht) {
1578 var object kvt = TheHashtable(ht)->ht_kvtable;
1579 if (simple_vector_p(kvt))
1580 return NIL;
1581 else switch (Record_type(kvt)) {
1582 case Rectype_WeakHashedAlist_Key: { return S(Kkey); }
1583 case Rectype_WeakHashedAlist_Value: { return S(Kvalue); }
1584 case Rectype_WeakHashedAlist_Either: { return S(Kkey_and_value); }
1585 case Rectype_WeakHashedAlist_Both: { return S(Kkey_or_value); }
1586 default: NOTREACHED;
1587 }
1588 }
1589
1590 /* UP: Allocates the key-value-table for a new hash-table.
1591 allocate_kvt(weak,maxcount)
1592 > weak: NIL or :KEY or :VALUE or :KEY-AND-VALUE or :KEY-OR-VALUE
1593 > maxcount: number of key/value pairs to make room for
1594 < result: a key-value-table
1595 can trigger GC */
allocate_kvt(object weak,uintL maxcount)1596 local inline maygc object allocate_kvt (object weak, uintL maxcount) {
1597 if (nullp(weak)) {
1598 var object kvt = allocate_vector(4+3*maxcount);
1599 TheHashedAlist(kvt)->hal_freelist = nix; /* dummy as free-list */
1600 return kvt;
1601 } else {
1602 var sintB rectype;
1603 if (eq(weak,S(Kkey))) /* :KEY */
1604 rectype = Rectype_WeakHashedAlist_Key;
1605 else if (eq(weak,S(Kvalue))) /* :VALUE */
1606 rectype = Rectype_WeakHashedAlist_Value;
1607 else if (eq(weak,S(Kkey_and_value))) /* :KEY-AND-VALUE */
1608 rectype = Rectype_WeakHashedAlist_Either;
1609 else if (eq(weak,S(Kkey_or_value))) /* :KEY-OR-VALUE */
1610 rectype = Rectype_WeakHashedAlist_Both;
1611 else
1612 NOTREACHED;
1613 var object kvt = allocate_lrecord(rectype,4+3*maxcount,lrecord_type);
1614 TheWeakHashedAlist(kvt)->wp_cdr = unbound; /* a GC-invariant dummy */
1615 TheWeakHashedAlist(kvt)->whal_itable = unbound;
1616 TheWeakHashedAlist(kvt)->whal_count = Fixnum_0;
1617 TheWeakHashedAlist(kvt)->whal_freelist = nix; /* dummy as free-list */
1618 var uintL i;
1619 for (i = 0; i < maxcount; i++) {
1620 TheWeakHashedAlist(kvt)->whal_data[3*i+0] = unbound;
1621 TheWeakHashedAlist(kvt)->whal_data[3*i+1] = unbound;
1622 TheWeakHashedAlist(kvt)->whal_data[3*i+2] = leer;
1623 }
1624 activate_weak(kvt); /* add to O(all_weakpointers) */
1625 return kvt;
1626 }
1627 }
1628
1629 /* UP: Provides the numbers and vectors for a new hash-table.
1630 prepare_resize(maxcount,mincount_threshold,weak)
1631 > maxcount: wished new size MAXCOUNT
1632 > mincount_threshold: short-float MINCOUNT-THRESHOLD
1633 > weak: NIL or :KEY or :VALUE or :KEY-AND-VALUE or :KEY-OR-VALUE
1634 < result: maxcount
1635 < stack-layout: MAXCOUNT, SIZE, MINCOUNT, index-vector, key-value-vector.
1636 decreases STACK by 5
1637 can trigger GC */
prepare_resize(object maxcount,object mincount_threshold,object weak)1638 local maygc uintL prepare_resize (object maxcount, object mincount_threshold,
1639 object weak) {
1640 prepare_resize_restart:
1641 /* check, if maxcount is not a too big fixnum >0 : */
1642 if (!posfixnump(maxcount))
1643 goto check_maxcount;
1644 {
1645 var uintV maxcountV = posfixnum_to_V(maxcount);
1646 var uintV sizeV = 2*maxcountV+1;
1647 /* SIZE odd in order to improve the hash-function! */
1648 if (!(4+3*maxcountV <= arraysize_limit_1+1))
1649 /* kvtable size should fit into ARRAY-SIZE-LIMIT */
1650 goto check_maxcount;
1651 #if 0 /* Redundant because 2*maxcountV+1 < 4+3*maxcountV ≤ arraysize_limit. */
1652 if (!(sizeV <= (uintV)(vbitm(oint_data_len)-1)))
1653 /* sizeV should fit into a fixnum */
1654 goto check_maxcount;
1655 #endif
1656 if (!(sizeV <= (uintL)(bitm(intLsize)-1)))
1657 /* sizeV should fit into an uintL */
1658 goto check_maxcount;
1659 /* numbers on the stack: */
1660 pushSTACK(maxcount); /* MAXCOUNT */
1661 pushSTACK(fixnum(sizeV)); /* SIZE */
1662 /* MINCOUNT := (floor (* maxcount mincount-threshold)) */
1663 pushSTACK(maxcount); pushSTACK(mincount_threshold); funcall(L(star),2);
1664 pushSTACK(value1); funcall(L(floor),1);
1665 pushSTACK(value1);
1666 /* stack-layout: MAXCOUNT, SIZE, MINCOUNT. */
1667 /* Allocate new index-vector: */
1668 {
1669 var object Ivektor = allocate_vector(sizeV);
1670 /* Fill it with "nix". For non-weak hash tables this is not really needed.
1671 But when weak /= NIL, during GC, weak_hashed_alist_update relies on
1672 the fact that unused entries are "nix", not NIL. And since
1673 (SETF HASH-TABLE-WEAK-P) can move the index-vector of a non-weak KVT
1674 into a weak KVT, it's best to initialize the index-vector of non-weak
1675 KVTs in the same way. */
1676 var gcv_object_t* ptr = &TheSvector(Ivektor)->data[0];
1677 var uintL count = sizeV; /* SIZE, >0 */
1678 dotimespL(count,count, { *ptr++ = nix; } );
1679 pushSTACK(Ivektor);
1680 }
1681 /* Allocate new key-value-vector: */
1682 pushSTACK(allocate_kvt(weak,maxcountV));
1683 /* finished. */
1684 return maxcountV;
1685 }
1686 check_maxcount: /* maxcount no fixnum or too big */
1687 pushSTACK(weak); pushSTACK(mincount_threshold); /* save */
1688 pushSTACK(NIL); /* no PLACE */
1689 pushSTACK(maxcount); /* TYPE-ERROR slot DATUM */
1690 pushSTACK(O(type_hashtable_size)); /* TYPE-ERROR slot EXPECTED-TYPE */
1691 pushSTACK(maxcount);
1692 check_value(type_error,GETTEXT("Hash table size ~S too large"));
1693 maxcount = value1;
1694 mincount_threshold = popSTACK(); weak = popSTACK(); /* restore */
1695 goto prepare_resize_restart;
1696 }
1697
1698 /* UP: Enlarges or diminishes a hash-table
1699 resize(ht,maxcount)
1700 > ht: hash-table
1701 > maxcount: wished new size MAXCOUNT
1702 < result: hash-table, EQ to the old one
1703 can trigger GC */
resize(object ht,object maxcount)1704 local maygc object resize (object ht, object maxcount) {
1705 pushSTACK(ht);
1706 var uintL maxcountL =
1707 prepare_resize(maxcount,TheHashtable(ht)->ht_mincount_threshold,
1708 hash_table_weak_type(ht));
1709 /* no GC from now on! */
1710 var object KVvektor = popSTACK(); /* new key-value-vector */
1711 var object Ivektor = popSTACK(); /* index-vector */
1712 var object mincount = popSTACK(); /* MINCOUNT */
1713 var object size = popSTACK(); /* SIZE */
1714 maxcount = popSTACK();
1715 ht = popSTACK();
1716 TheHashedAlist(KVvektor)->hal_itable = Ivektor; /* enter new index-vector */
1717 /* Fill new key-value-vector:
1718 Loop over the old key-value-vector and
1719 copy all key-value-pairs with key /= "leer" :
1720 For traversing the old key-value-vector: */
1721 var uintL oldcount = posfixnum_to_V(TheHashtable(ht)->ht_maxcount);
1722 var object oldKVvektor = TheHashtable(ht)->ht_kvtable;
1723 var gcv_object_t* oldKVptr = &TheHashedAlist(oldKVvektor)->hal_data[0];
1724 /* For traversing the new key-value-vector: */
1725 var uintL count = maxcountL;
1726 var gcv_object_t* KVptr = &TheHashedAlist(KVvektor)->hal_data[0];
1727 /* For counting: */
1728 var object counter = Fixnum_0;
1729 dotimesL(oldcount,oldcount, {
1730 var object nextkey = *oldKVptr++; /* next key */
1731 var object nextvalue = *oldKVptr++; /* and value */
1732 oldKVptr++;
1733 if (!eq(nextkey,leer)) {
1734 /* take over the entry into the new key-value-vector: */
1735 if (count==0) { /* is the new vector already full? */
1736 /* There is not enough room!! */
1737 pushSTACK(ht); /* hash-table */
1738 error(serious_condition,
1739 GETTEXT("internal error occured while resizing ~S"));
1740 }
1741 count--;
1742 *KVptr++ = nextkey; *KVptr++ = nextvalue; /* file in new vector */
1743 *KVptr++ = nix;
1744 counter = fixnum_inc(counter,1); /* and count */
1745 }
1746 });
1747 /* Mark 'count' pairs of the new key-value-vector as "leer" : */
1748 dotimesL(count,count, { *KVptr++ = leer; *KVptr++ = leer; *KVptr++ = leer; } );
1749 TheHashedAlist(KVvektor)->hal_count = counter; /* enter COUNT (for consistency) */
1750 /* modify hash-table: */
1751 set_break_sem_2(); /* protect from breaks */
1752 set_ht_invalid(TheHashtable(ht)); /* table must still be reorganized */
1753 TheHashtable(ht)->ht_size = posfixnum_to_V(size); /* enter new SIZE */
1754 TheHashtable(ht)->ht_maxcount = maxcount; /* enter new MAXCOUNT */
1755 TheHashtable(ht)->ht_kvtable = KVvektor; /* enter new key-value-vector */
1756 TheHashtable(ht)->ht_mincount = mincount; /* enter new MINCOUNT */
1757 clr_break_sem_2(); /* allow breaks again */
1758 return ht;
1759 }
1760
1761 /* Macro: Enlarges a hash-table until freelist /= nix
1762 hash_prepare_store(hash_pos,key_pos);
1763 > int literal: hash-table position in STACK
1764 > int literal: key position in STACK
1765 < object ht: hash-table
1766 < object freelist: start of the free-list in the next-vector, /= nix
1767 < gcv_object_t* Iptr: arbitrary element of the "list", that belongs to the key
1768 for EQ/EQL/EQUAL/EQUALP hashtables the hash code changes after GC,
1769 so the raw hashcode cannot be cached.
1770 for user-defined hashtables, raw hashcode caching is good
1771 (especially for the user-defined tables, where hashcode can trigger GC!)
1772 can trigger GC */
1773 #define hash_prepare_store(hash_pos,key_pos) \
1774 do { \
1775 ht = STACK_(hash_pos); \
1776 freelist = TheHashedAlist(TheHashtable(ht)->ht_kvtable)->hal_freelist; \
1777 if (eq(freelist,nix)) { /* free-list = empty "list" ? */ \
1778 var uintB flags = record_flags(TheHashtable(ht)); \
1779 var bool cacheable = ht_test_code_user_p(ht_test_code(flags)); /* not EQ|EQL|EQUAL|EQUALP */ \
1780 var uintL hc_raw = cacheable ? hashcode_raw(ht,STACK_(key_pos)) : 0; \
1781 ht = STACK_(hash_pos); /* hashcode_raw maygc */ \
1782 do { /* hash-table must still be enlarged: */ \
1783 /* calculate new maxcount: */ \
1784 pushSTACK(TheHashtable(ht)->ht_maxcount); \
1785 pushSTACK(TheHashtable(ht)->ht_rehash_size); /* REHASH-SIZE (>1) */ \
1786 funcall(L(star),2); /* (* maxcount rehash-size), is > maxcount */ \
1787 pushSTACK(value1); \
1788 funcall(L(ceiling),1); /* (ceiling ...), integer > maxcount */ \
1789 ht = resize(STACK_(hash_pos),value1); /* enlarge table */ \
1790 ht = rehash(ht); /* and reorganize */ \
1791 /* newly calculate the address of the entry in the index-vector: */ \
1792 { var uintL hashindex = \
1793 (cacheable ? hashcode_cook(hc_raw,TheHashtable(ht)->ht_size) \
1794 : hashcode(ht,STACK_(key_pos))); \
1795 var object kvtable = TheHashtable(ht)->ht_kvtable; \
1796 Iptr = &TheSvector(TheHashedAlist(kvtable)->hal_itable)->data[hashindex]; \
1797 freelist = TheHashedAlist(kvtable)->hal_freelist; \
1798 } \
1799 } while (eq(freelist,nix)); \
1800 } \
1801 } while(0)
1802
1803 /* UP: Deletes the content of a hash-table.
1804 clrhash(ht);
1805 > ht: hash-table */
clrhash(object ht)1806 local void clrhash (object ht) {
1807 set_break_sem_2(); /* protect from breaks */
1808 var object kvtable = TheHashtable(ht)->ht_kvtable;
1809 /* Delete pairs and build up freelist: */
1810 {
1811 var object index = TheHashtable(ht)->ht_maxcount; /* MAXCOUNT */
1812 var uintL maxcount = posfixnum_to_V(index);
1813 var object freelist = nix;
1814 if (maxcount > 0) {
1815 var gcv_object_t* KVptr = &TheHashedAlist(kvtable)->hal_data[3*maxcount]; /* end of kvtable */
1816 do {
1817 index = fixnum_inc(index,-1); /* decrement index */
1818 *--KVptr = freelist; /* delete next-index */
1819 *--KVptr = leer; *--KVptr = leer; /* delete key and value */
1820 freelist = index;
1821 } while (!eq(index,Fixnum_0));
1822 }
1823 TheHashedAlist(kvtable)->hal_freelist = freelist; /* save freelist */
1824 }
1825 TheHashedAlist(kvtable)->hal_count = Fixnum_0; /* COUNT := 0 */
1826 /* Fill index-vector with "nix" : */
1827 var object Ivektor = TheHashedAlist(kvtable)->hal_itable; /* index-vector */
1828 {
1829 var gcv_object_t* ptr = &TheSvector(Ivektor)->data[0];
1830 var uintL count = TheHashtable(ht)->ht_size; /* SIZE, >0 */
1831 dotimespL(count,count, { *ptr++ = nix; } );
1832 }
1833 record_flags_clr(TheHashtable(ht),htflags_gc_rehash_B); /* no dangerous keys now */
1834 set_ht_valid(TheHashtable(ht)); /* hashtable is now completely organized */
1835 clr_break_sem_2(); /* allow breaks again */
1836 }
1837
1838 /* UP: fetches the value of *eq-hashfunction*. */
get_eq_hashfunction(void)1839 local object get_eq_hashfunction (void) {
1840 var object value = Symbol_value(S(eq_hashfunction));
1841 if (eq(value,S(fasthash_eq)) || eq(value,S(stablehash_eq)))
1842 return value;
1843 else {
1844 Symbol_value(S(eq_hashfunction)) = S(fasthash_eq);
1845 pushSTACK(value); /* TYPE-ERROR slot DATUM */
1846 pushSTACK(O(type_eq_hashfunction)); /* TYPE-ERROR slot EXPECTED-TYPE */
1847 pushSTACK(S(fasthash_eq));
1848 pushSTACK(value);
1849 pushSTACK(S(stablehash_eq)); pushSTACK(S(fasthash_eq));
1850 pushSTACK(S(eq_hashfunction));
1851 pushSTACK(TheSubr(subr_self)->name);
1852 error(type_error,
1853 GETTEXT("~S: The value of ~S should be ~S or ~S, not ~S.\n"
1854 "It has been reset to ~S."));
1855 }
1856 }
1857
1858 /* UP: fetches the value of *eql-hashfunction*. */
get_eql_hashfunction(void)1859 local object get_eql_hashfunction (void) {
1860 var object value = Symbol_value(S(eql_hashfunction));
1861 if (eq(value,S(fasthash_eql)) || eq(value,S(stablehash_eql)))
1862 return value;
1863 else {
1864 Symbol_value(S(eql_hashfunction)) = S(fasthash_eql);
1865 pushSTACK(value); /* TYPE-ERROR slot DATUM */
1866 pushSTACK(O(type_eql_hashfunction)); /* TYPE-ERROR slot EXPECTED-TYPE */
1867 pushSTACK(S(fasthash_eql));
1868 pushSTACK(value);
1869 pushSTACK(S(stablehash_eql)); pushSTACK(S(fasthash_eql));
1870 pushSTACK(S(eql_hashfunction));
1871 pushSTACK(TheSubr(subr_self)->name);
1872 error(type_error,
1873 GETTEXT("~S: The value of ~S should be ~S or ~S, not ~S.\n"
1874 "It has been reset to ~S."));
1875 }
1876 }
1877
1878 /* UP: fetches the value of *equal-hashfunction*. */
get_equal_hashfunction(void)1879 local object get_equal_hashfunction (void) {
1880 var object value = Symbol_value(S(equal_hashfunction));
1881 if (eq(value,S(fasthash_equal)) || eq(value,S(stablehash_equal)))
1882 return value;
1883 else {
1884 Symbol_value(S(equal_hashfunction)) = S(fasthash_equal);
1885 pushSTACK(value); /* TYPE-ERROR slot DATUM */
1886 pushSTACK(O(type_equal_hashfunction)); /* TYPE-ERROR slot EXPECTED-TYPE */
1887 pushSTACK(S(fasthash_equal));
1888 pushSTACK(value);
1889 pushSTACK(S(stablehash_equal)); pushSTACK(S(fasthash_equal));
1890 pushSTACK(S(equal_hashfunction));
1891 pushSTACK(TheSubr(subr_self)->name);
1892 error(type_error,
1893 GETTEXT("~S: The value of ~S should be ~S or ~S, not ~S.\n"
1894 "It has been reset to ~S."));
1895 }
1896 }
1897
1898 /* check the :WEAK argument and return it
1899 can trigger GC */
check_weak(object weak)1900 local maygc object check_weak (object weak) {
1901 check_weak_restart:
1902 if (missingp(weak)) return NIL;
1903 if (eq(weak,S(Kkey)) || eq(weak,S(Kvalue))
1904 || eq(weak,S(Kkey_and_value)) || eq(weak,S(Kkey_or_value)))
1905 return weak;
1906 /* invalid */
1907 pushSTACK(NIL); /* no PLACE */
1908 pushSTACK(weak); /* TYPE-ERROR slot DATUM */
1909 pushSTACK(O(type_weak_ht)); /* TYPE-ERROR slot EXPECTED-TYPE */
1910 pushSTACK(NIL); pushSTACK(S(Kkey)); pushSTACK(S(Kvalue));
1911 pushSTACK(S(Kkey_and_value)); pushSTACK(S(Kkey_or_value));
1912 pushSTACK(weak); pushSTACK(TheSubr(subr_self)->name);
1913 check_value(type_error,GETTEXT("~S: argument ~S should be ~S, ~S, ~S, ~S or ~S."));
1914 weak = value1;
1915 goto check_weak_restart;
1916 }
1917
1918 /* (MAKE-HASH-TABLE [:test] [:size] [:rehash-size] [:rehash-threshold]
1919 [:key-type] [:value-type]
1920 [:weak] [:warn-if-needs-rehash-after-gc] [:initial-contents]), CLTL p. 283 */
1921 LISPFUN(make_hash_table,seclass_read,0,0,norest,key,9,
1922 (kw(initial_contents),kw(key_type),kw(value_type),
1923 kw(warn_if_needs_rehash_after_gc),kw(weak),
1924 kw(test),kw(size),kw(rehash_size),kw(rehash_threshold)) )
1925 { /* The rehash-threshold correlates in our implementation to the
1926 ratio MAXCOUNT : SIZE = ca. 1 : 2.
1927 We ignore the rehash-threshold-argument, as both too big values and
1928 also too small values could be harmful: 0.99 causes on average
1929 too long access-times; 0.00001 causes, that SIZE = MAXCOUNT/threshold
1930 could become a bignum too fast.
1931 The additional initial-contents-argument is an alist = list of
1932 (key . value) - pairs, that are used to initialize the table.
1933 STACK layout:
1934 initial-contents, key-type, value-type,
1935 warn-if-needs-rehash-after-gc, weak,
1936 test, size, rehash-size, rehash-threshold. */
1937 var uintB flags;
1938 var object lookuppfn;
1939 var object hashcodepfn;
1940 var object testpfn;
1941 var object gcinvariantpfn;
1942 check_test_restart: { /* check test-argument: */
1943 var object test = STACK_3;
1944 if (!boundp(test) || eq(test,S(eql)) || eq(test,L(eql)))
1945 test = get_eql_hashfunction();
1946 if (eq(test,S(fasthash_eql))) {
1947 flags = htflags_test_eql_B; /* FASTHASH-EQL */
1948 hashcodepfn = P(hashcode2);
1949 gcinvariantpfn = P(gcinvariant_hashcode2_p);
1950 testpfn = P(eql);
1951 lookuppfn = P(hash_lookup_builtin);
1952 } else if (eq(test,S(stablehash_eql))) {
1953 flags = htflags_test_eql_B | htflags_stablehash_B; /* STABLEHASH-EQL */
1954 hashcodepfn = P(hashcode2stable);
1955 gcinvariantpfn = P(gcinvariant_hashcode2stable_p);
1956 testpfn = P(eql);
1957 lookuppfn = P(hash_lookup_builtin);
1958 } else {
1959 if (eq(test,S(eq)) || eq(test,L(eq)))
1960 test = get_eq_hashfunction();
1961 if (eq(test,S(fasthash_eq))) {
1962 flags = htflags_test_eq_B; /* FASTHASH-EQ */
1963 hashcodepfn = unbound; /* specially handled in hashcode_builtin */
1964 gcinvariantpfn = P(gcinvariant_hashcode1_p);
1965 testpfn = unbound; /* specially handled in hash_lookup_builtin */
1966 lookuppfn = P(hash_lookup_builtin);
1967 } else if (eq(test,S(stablehash_eq))) {
1968 flags = htflags_test_eq_B | htflags_stablehash_B; /* STABLEHASH-EQ */
1969 hashcodepfn = P(hashcode1stable);
1970 gcinvariantpfn = P(gcinvariant_hashcode1stable_p);
1971 testpfn = unbound; /* specially handled in hash_lookup_builtin */
1972 lookuppfn = P(hash_lookup_builtin);
1973 } else {
1974 if (eq(test,S(equal)) || eq(test,L(equal)))
1975 test = get_equal_hashfunction();
1976 if (eq(test,S(fasthash_equal))) {
1977 flags = htflags_test_equal_B; /* FASTHASH-EQUAL */
1978 hashcodepfn = P(hashcode3);
1979 gcinvariantpfn = P(gcinvariant_hashcode3_p);
1980 testpfn = P(equal);
1981 lookuppfn = P(hash_lookup_builtin);
1982 } else if (eq(test,S(stablehash_equal))) {
1983 flags = htflags_test_equal_B | htflags_stablehash_B; /* STABLEHASH-EQUAL */
1984 hashcodepfn = P(hashcode3stable);
1985 gcinvariantpfn = P(gcinvariant_hashcode3stable_p);
1986 testpfn = P(equal);
1987 lookuppfn = P(hash_lookup_builtin);
1988 } else if (eq(test,S(equalp)) || eq(test,L(equalp))) {
1989 flags = htflags_test_equalp_B; /* EQUALP */
1990 hashcodepfn = P(hashcode4);
1991 gcinvariantpfn = P(gcinvariant_hashcode4_p);
1992 testpfn = P(equalp);
1993 lookuppfn = P(hash_lookup_builtin);
1994 } else {
1995 hashcodepfn = unbound;
1996 gcinvariantpfn = unbound;
1997 testpfn = unbound;
1998 lookuppfn = P(hash_lookup_user);
1999 if (symbolp(test)) {
2000 var object ht_test = get(test,S(hash_table_test));
2001 if (!consp(ht_test)) goto test_error;
2002 STACK_3 = ht_test;
2003 flags = htflags_test_user_B; /* user-defined ht_test */
2004 } else if (consp(test)) {
2005 flags = htflags_test_user_B; /* ad hoc (user-defined ht_test) */
2006 } else {
2007 test_error:
2008 pushSTACK(NIL); /* no PLACE */
2009 pushSTACK(test); /* TYPE-ERROR slot DATUM */
2010 pushSTACK(O(type_hashtable_test)); /* TYPE-ERROR slot EXPECTED-TYPE */
2011 pushSTACK(test); pushSTACK(S(Ktest));
2012 pushSTACK(S(make_hash_table));
2013 check_value(type_error,GETTEXT("~S: Illegal ~S argument ~S"));
2014 STACK_3 = value1;
2015 goto check_test_restart;
2016 }
2017 }
2018 }
2019 }
2020 } /* flags contains the flags for the test. */
2021 check_size: { /* check size-argument: */
2022 var object size = STACK_2;
2023 if (!boundp(size)) {
2024 STACK_2 = Fixnum_1; /* 1 as default */
2025 } else {
2026 if (!posfixnump(size)) {
2027 pushSTACK(NIL); /* no PLACE */
2028 pushSTACK(size); /* TYPE-ERROR slot DATUM */
2029 pushSTACK(O(type_posfixnum)); /* TYPE-ERROR slot EXPECTED-TYPE */
2030 pushSTACK(size); pushSTACK(S(Ksize));
2031 pushSTACK(S(make_hash_table));
2032 check_value(type_error,GETTEXT("~S: ~S argument should be a fixnum >=0, not ~S"));
2033 STACK_2 = value1;
2034 goto check_size;
2035 }
2036 /* size is a fixnum >=0 */
2037 if (eq(size,Fixnum_0))
2038 STACK_2 = Fixnum_1; /* turn 0 into 1 */
2039 }
2040 } /* size is now a fixnum >0. */
2041 check_rehash_size: { /* (OR (INTEGER 1 *) (FLOAT (1.0) *)) */
2042 if (!boundp(STACK_1)) { /* default-rehash-size = 1.5s0 */
2043 STACK_1 = make_SF(0,SF_exp_mid+1,(bit(SF_mant_len)*3)/2);
2044 } else {
2045 if (!floatp(STACK_1)) { /* Float is OK */
2046 if (!integerp(STACK_1) || R_minusp(STACK_1) || eq(STACK_1,Fixnum_0)) {
2047 /* else it should be a positive integer */
2048 bad_rehash_size:
2049 pushSTACK(NIL); /* no PLACE */
2050 pushSTACK(STACK_(1+1)); /* TYPE-ERROR slot DATUM */
2051 pushSTACK(O(type_hashtable_rehash_size)); /* EXPECTED-TYPE */
2052 pushSTACK(STACK_(1+3)); pushSTACK(S(Krehash_size));
2053 pushSTACK(S(make_hash_table));
2054 check_value(type_error,GETTEXT("~S: ~S argument should be an integer or a float > 1, not ~S"));
2055 STACK_1 = value1;
2056 goto check_rehash_size;
2057 }
2058 /* As it is senseless to enlarge a table always only by a fixed
2059 number of elements (results in disastrous inefficiency), we set
2060 rehash-size := min(1 + rehash-size/size , 2.0) . */
2061 pushSTACK(STACK_1); /* rehash-size */
2062 pushSTACK(STACK_(2+1)); /* size */
2063 funcall(L(slash),2); /* (/ rehash-size size) */
2064 pushSTACK(value1);
2065 funcall(L(plus_one),1); /* (1+ ...) */
2066 pushSTACK(value1);
2067 pushSTACK(make_SF(0,SF_exp_mid+2,bit(SF_mant_len))); /* 2.0s0 */
2068 funcall(L(min),2); /* (MIN ... 2.0s0) */
2069 STACK_1 = value1; /* =: rehash-size */
2070 }
2071 { /* check (> rehash-size 1) : */
2072 pushSTACK(STACK_1); /* rehash-size */
2073 pushSTACK(Fixnum_1); /* 1 */
2074 funcall(L(greater),2); /* (> rehash-size 1) */
2075 }
2076 if (nullp(value1)) goto bad_rehash_size;
2077 /* convert rehash-size into a short-float: */
2078 pushSTACK(STACK_1); /* rehash-size */
2079 pushSTACK(SF_0); /* 0.0s0 */
2080 funcall(L(float),2); /* (FLOAT rehash-size 0.0s0) = (COERCE rehash-size 'SHORT-FLOAT) */
2081 /* enforce (>= rehash-size 1.125s0) : */
2082 pushSTACK(value1);
2083 pushSTACK(make_SF(0,SF_exp_mid+1,(bit(SF_mant_len)/8)*9)); /* 1.125s0 */
2084 funcall(L(max),2); /* (max rehash-size 1.125s0) */
2085 STACK_1 = value1; /* =: rehash-size */
2086 }
2087 } /* rehash-size is a short-float >= 1.125 . */
2088 check_rehash_threshold: { /* check rehash-threshold: should be real in [0;1]*/
2089 var object rehash_threshold = STACK_0;
2090 if (boundp(rehash_threshold)) { /* not specified -> OK */
2091 if_realp(rehash_threshold, ;, goto bad_rehash_threshold;);
2092 if (false) {
2093 bad_rehash_threshold:
2094 pushSTACK(NIL); /* no PLACE */
2095 pushSTACK(rehash_threshold); /* TYPE-ERROR slot DATUM */
2096 pushSTACK(O(type_hashtable_rehash_threshold)); /* TYPE-ERROR slot EXPECTED-TYPE */
2097 pushSTACK(STACK_1); pushSTACK(S(Krehash_threshold));
2098 pushSTACK(S(make_hash_table));
2099 check_value(type_error,GETTEXT("~S: ~S argument should be a real between 0 and 1, not ~S"));
2100 STACK_0 = value1;
2101 goto check_rehash_threshold;
2102 }
2103 pushSTACK(Fixnum_1);
2104 pushSTACK(rehash_threshold);
2105 pushSTACK(Fixnum_0);
2106 funcall(L(gtequal),3); /* (>= 1 rehash-threshold 0) */
2107 if (nullp(value1)) goto bad_rehash_threshold;
2108 }
2109 }
2110 { /* If the initial-contents-argument is specified, we set
2111 size := (max size (length initial-contents)) , so afterwards, when
2112 the initial-contents are written, the table needs not be enlarged: */
2113 var object initial_contents = STACK_8;
2114 if (boundp(initial_contents)) { /* specified ? */
2115 var uintL initial_length = llength(initial_contents); /* length of the alist */
2116 if (initial_length > posfixnum_to_V(STACK_2)) /* > size ? */
2117 STACK_2 = fixnum(initial_length); /* yes -> enlarge size */
2118 }
2119 } /* size is a fixnum >0, >= (length initial-contents) . */
2120 { /* calculate MINCOUNT-THRESHOLD = 1/rehash-size^2 : */
2121 var object rehash_size = STACK_1;
2122 pushSTACK(rehash_size);
2123 pushSTACK(rehash_size);
2124 funcall(L(star),2); /* (* rehash-size rehash-size) */
2125 pushSTACK(value1);
2126 funcall(L(slash),1); /* (/ ...) */
2127 STACK_0 = value1;
2128 }
2129 /* STACK layout:
2130 initial-contents, key-type, value-type,
2131 warn-if-needs-rehash-after-gc, weak,
2132 test, size, rehash-size, mincount-threshold
2133 provide vectors etc., with size as MAXCOUNT: [STACK_4 == weak] */
2134 STACK_4 = check_weak(STACK_4);
2135 prepare_resize(STACK_2,STACK_0,STACK_4);
2136 var object ht = allocate_hash_table(); /* new hash-tabelle */
2137 /* fill: */
2138 var object kvtable = popSTACK(); /* key-value-vector */
2139 TheHashtable(ht)->ht_kvtable = kvtable;
2140 TheHashedAlist(kvtable)->hal_itable = popSTACK(); /* index-vector */
2141 TheHashtable(ht)->ht_mincount = popSTACK(); /* MINCOUNT */
2142 TheHashtable(ht)->ht_size = posfixnum_to_V(popSTACK()); /* SIZE */
2143 TheHashtable(ht)->ht_maxcount = popSTACK(); /* MAXCOUNT */
2144 /* STACK layout:
2145 initial-contents, key-type, value-type,
2146 warn-if-needs-rehash-after-gc, weak,
2147 test, size, rehash-size, mincount-threshold. */
2148 TheHashtable(ht)->ht_mincount_threshold = popSTACK(); /*MINCOUNT-THRESHOLD*/
2149 TheHashtable(ht)->ht_rehash_size = popSTACK(); /* REHASH-SIZE */
2150 TheHashtable(ht)->ht_lookupfn = lookuppfn;
2151 TheHashtable(ht)->ht_hashcodefn = hashcodepfn;
2152 TheHashtable(ht)->ht_testfn = testpfn;
2153 TheHashtable(ht)->ht_gcinvariantfn = gcinvariantpfn;
2154 /* STACK layout:
2155 initial-contents, key-type, value-type,
2156 warn-if-needs-rehash-after-gc, weak, test, -. */
2157 if (ht_test_code_user_p(ht_test_code(flags))) { /* user-defined ht_test */
2158 STACK_0 = ht;
2159 var object test = coerce_function(Car(STACK_1)); pushSTACK(test);
2160 var object hash = coerce_function(Cdr(STACK_2));
2161 ht = STACK_1;
2162 TheHashtable(ht)->ht_test = popSTACK();
2163 TheHashtable(ht)->ht_hash = hash;
2164 }
2165 /* Use warn-if-needs-rehash-after-gc argument. */
2166 if (!missingp(STACK_3))
2167 flags |= htflags_warn_gc_rehash_B;
2168 record_flags_replace(TheHashtable(ht), flags);
2169 clrhash(ht); /* empty table, COUNT := 0 */
2170 skipSTACK(6);
2171 /* stack-layout: initial-contents. */
2172 {
2173 pushSTACK(ht);
2174 while (consp(STACK_1)) { /* if it was specified, so long as it was a cons: */
2175 var object next = Car(STACK_1); /* alist element */
2176 if (consp(next)) { /* a cons (Key . Value) ? */
2177 /* execute (SYSTEM::PUTHASH (car next) hashtable (cdr next)) ,
2178 whereby the table cannot grow: */
2179 var gcv_object_t* KVptr;
2180 var gcv_object_t* Iptr;
2181 if (hash_lookup(STACK_0,Car(next),true,&KVptr,&Iptr)) { /* search */
2182 /* already found -> was already contained in the alist further
2183 on the left, and in alists the first association (left)
2184 shadows all other associations of the same key. */
2185 ht = STACK_0; /* restore ht */
2186 } else { /* not found -> make a new entry: */
2187 var object freelist = /* start of the free-list in the next-vector */
2188 TheHashedAlist(TheHashtable(STACK_0)->ht_kvtable)->hal_freelist;
2189 if (eq(freelist,nix)) { /* empty "list" ? */
2190 pushSTACK(STACK_0); /* hash-table */
2191 pushSTACK(S(make_hash_table));
2192 error(serious_condition,
2193 GETTEXT("~S: internal error while building ~S"));
2194 }
2195 ht = STACK_0; /* restore ht */
2196 next = Car(STACK_1); /* restore next */
2197 hash_store(Car(next),Cdr(next)); /* make entry */
2198 }
2199 }
2200 STACK_1 = Cdr(STACK_1); /* pop alist */
2201 }
2202 skipSTACK(2); /* drop ht, initial-contents */
2203 }
2204 VALUES1(ht); /* hash-table as value */
2205 }
2206
2207 /* UP: Searches an object in a hash-table.
2208 gethash(obj,ht,allowgc)
2209 > obj: object, as key
2210 > ht: hash-table
2211 > allowgc: whether GC is allowed during hash lookup
2212 (should be true if the hash-table has a user-defined test)
2213 < result: if found, belonging value, else nullobj
2214 can trigger GC - if allowgc is true */
gethash(object obj,object ht,bool allowgc)2215 modexp /*maygc*/ object gethash (object obj, object ht, bool allowgc) {
2216 GCTRIGGER_IF(allowgc, GCTRIGGER2(obj,ht));
2217 var gcv_object_t* KVptr;
2218 var gcv_object_t* Iptr;
2219 if (hash_lookup(ht,obj,allowgc,&KVptr,&Iptr))
2220 return KVptr[1]; /* found -> value */
2221 else
2222 return nullobj;
2223 }
2224
2225 /* error, if an argument is not a hash-table
2226 check_hashtable(obj);
2227 > obj: object
2228 < hashtable
2229 can trigger GC */
check_hashtable(object obj)2230 local maygc object check_hashtable (object obj) {
2231 while (!hash_table_p(obj)) {
2232 pushSTACK(NIL); /* no PLACE */
2233 pushSTACK(obj); /* TYPE-ERROR slot DATUM */
2234 pushSTACK(S(hash_table)); /* TYPE-ERROR slot EXPECTED-TYPE */
2235 pushSTACK(obj);
2236 pushSTACK(TheSubr(subr_self)->name);
2237 check_value(type_error,GETTEXT("~S: argument ~S is not a hash table"));
2238 obj = value1;
2239 }
2240 return obj;
2241 }
2242
2243 LISPFUN(gethash,seclass_read,2,1,norest,nokey,0,NIL)
2244 { /* (GETHASH key hashtable [default]), CLTL p. 284 */
2245 var object ht = check_hashtable(STACK_1); /* hashtable argument */
2246 var gcv_object_t* KVptr;
2247 var gcv_object_t* Iptr;
2248 /* search key STACK_2 in the hash-table: */
2249 if (hash_lookup(ht,STACK_2,true,&KVptr,&Iptr)) { /* -> Value as value: */
2250 VALUES2(KVptr[1], T); /* and T as the 2nd value */
2251 skipSTACK(3);
2252 } else { /* not found -> default or NIL as value */
2253 var object def = popSTACK(); /* default */
2254 VALUES2(!boundp(def) ? NIL : def,
2255 NIL); /* NIL as the 2nd value */
2256 skipSTACK(2);
2257 }
2258 }
2259
2260 LISPFUNN(puthash,3)
2261 { /* (SYSTEM::PUTHASH key hashtable value) =
2262 (SETF (GETHASH key hashtable) value), CLTL p. 284 */
2263 STACK_1 = check_hashtable(STACK_1); /* hashtable argument */
2264 var gcv_object_t* KVptr;
2265 var gcv_object_t* Iptr;
2266 /* search key STACK_2 in the hash-table: */
2267 if (hash_lookup(STACK_1,STACK_2,true,&KVptr,&Iptr)) { /* -> replace value: */
2268 VALUES1(KVptr[1] = popSTACK()); skipSTACK(2);
2269 } else { /* not found -> make new entry: */
2270 var object ht;
2271 var object freelist;
2272 hash_prepare_store(1,2); /* ht==STACK_1, obj==STACK_2 */
2273 hash_store(STACK_2,STACK_0); /* make entry */
2274 VALUES1(popSTACK()); /* value as value */
2275 skipSTACK(2);
2276 }
2277 }
2278
2279 /* UP: Searches a key in a hash-table and returns the last value.
2280 shifthash(ht,obj,value) == (SHIFTF (GETHASH obj ht) value)
2281 > ht: hash-table
2282 > obj: object
2283 > value: new value
2284 > allowgc: whether GC is allowed during hash lookup
2285 (should be true if the hash-table has a user-defined test or
2286 if the hash-table is not known to already contain a value for obj)
2287 < result: old value
2288 can trigger GC - if allowgc is true */
shifthash(object ht,object obj,object value,bool allowgc)2289 global /*maygc*/ object shifthash (object ht, object obj, object value, bool allowgc) {
2290 GCTRIGGER_IF(allowgc, GCTRIGGER3(ht,obj,value));
2291 var gcv_object_t* KVptr;
2292 var gcv_object_t* Iptr;
2293 pushSTACK(ht); pushSTACK(obj); pushSTACK(value); /* save args */
2294 /* search key obj in the hash-table: */
2295 if (hash_lookup(ht,obj,allowgc,&KVptr,&Iptr)) { /* found -> replace value: */
2296 var object oldvalue = KVptr[1];
2297 KVptr[1] = STACK_0; skipSTACK(3);
2298 return oldvalue;
2299 } else { /* not found -> build new entry: */
2300 ASSERT(allowgc);
2301 var object freelist;
2302 hash_prepare_store(2,1); /* ht==STACK_2, obj==STACK_1 */
2303 hash_store(STACK_1,STACK_0); /* build entry */
2304 skipSTACK(3);
2305 return NIL; /* default for the old value is NIL */
2306 }
2307 }
2308
2309 LISPFUNN(remhash,2)
2310 { /* (REMHASH key hashtable), CLTL p. 284 */
2311 STACK_0 = check_hashtable(STACK_0); /* hashtable argument */
2312 var object key = STACK_1; /* key-argument */
2313 var gcv_object_t* KVptr;
2314 var gcv_object_t* Iptr;
2315 /* search key in the hash-table: */
2316 if (hash_lookup(STACK_0,key,true,&KVptr,&Iptr)) {
2317 /* found -> drop from the hash-table: */
2318 var object ht = STACK_0; skipSTACK(2);
2319 var object kvtable = TheHashtable(ht)->ht_kvtable;
2320 var object index = *Iptr; /* index in next-vector */
2321 /* with KVptr = &TheHashedAlist(kvtable)->hal_data[3*index] */
2322 set_break_sem_2(); /* protect from breaks */
2323 *KVptr++ = leer; *KVptr++ = leer; /* empty key and value */
2324 *Iptr = *KVptr; /* shorten "list" */
2325 /* lengthen free-list: */
2326 *KVptr = TheHashedAlist(kvtable)->hal_freelist;
2327 TheHashedAlist(kvtable)->hal_freelist = index;
2328 /* decrement COUNT : */
2329 TheHashedAlist(kvtable)->hal_count = fixnum_inc(TheHashedAlist(kvtable)->hal_count,-1);
2330 clr_break_sem_2(); /* allow breaks again */
2331 /* shrink the hash-table for COUNT < MINCOUNT : */
2332 if ( posfixnum_to_V(TheHashedAlist(kvtable)->hal_count)
2333 < posfixnum_to_V(TheHashtable(ht)->ht_mincount)) {
2334 /* shrink hash-table:
2335 maxcount := (max (floor (/ maxcount rehash-size)) 1) */
2336 pushSTACK(ht); /* save hashtable */
2337 pushSTACK(TheHashtable(ht)->ht_maxcount);
2338 pushSTACK(TheHashtable(ht)->ht_rehash_size); /* REHASH-SIZE (>1) */
2339 funcall(L(slash),2); /* (/ maxcount rehash-size), is < maxcount */
2340 pushSTACK(value1);
2341 funcall(L(floor),1); /* (floor ...), an integer >=0, < maxcount */
2342 var object maxcount = value1;
2343 if (eq(maxcount,Fixnum_0))
2344 maxcount = Fixnum_1; /* turn 0 into 1 */
2345 resize(popSTACK(),maxcount); /* shrink table */
2346 }
2347 VALUES1(T);
2348 } else { /* not found */
2349 skipSTACK(2); VALUES1(NIL);
2350 }
2351 }
2352
2353 LISPFUNN(maphash,2)
2354 { /* (MAPHASH function hashtable), CLTL p. 285 */
2355 var object ht = check_hashtable(STACK_0); /* hashtable argument */
2356 /* traverse the key-value-vector in reverse direction and
2357 call the function for all key-value-pairs with key /= "leer" : */
2358 var uintL index = 3*posfixnum_to_V(TheHashtable(ht)->ht_maxcount);
2359 STACK_0 = TheHashtable(ht)->ht_kvtable; /* key-value-vector */
2360 /* stack-layout: function, key-value-vector. */
2361 while (index) {
2362 index -= 3;
2363 var gcv_object_t* KVptr = &TheHashedAlist(STACK_0)->hal_data[index];
2364 if (!eq(KVptr[0],leer)) { /* key /= "leer" ? */
2365 pushSTACK(KVptr[0]); /* key as the 1st argument */
2366 pushSTACK(KVptr[1]); /* value as the 2nd argument */
2367 funcall(STACK_(1+2),2); /* (FUNCALL function Key Value) */
2368 }
2369 }
2370 skipSTACK(2);
2371 VALUES1(NIL);
2372 }
2373
2374 LISPFUNN(clrhash,1)
2375 { /* (CLRHASH hashtable), CLTL p. 285 */
2376 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2377 clrhash(ht); /* empty table */
2378 /* Shrink the hash-table when MINCOUNT > 0 : */
2379 if (!eq(TheHashtable(ht)->ht_mincount,Fixnum_0))
2380 ht = resize(ht,Fixnum_1); /* shrink to MAXCOUNT:=1 , so that MINCOUNT:=0 */
2381 VALUES1(ht); /* hash-table as value */
2382 }
2383
2384 LISPFUNNR(hash_table_count,1)
2385 { /* (HASH-TABLE-COUNT hashtable), CLTL p. 285, CLtL2 p. 439 */
2386 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2387 var object count = TheHashedAlist(TheHashtable(ht)->ht_kvtable)->hal_count;
2388 VALUES1(count); /* fixnum COUNT as value */
2389 }
2390
2391 LISPFUNNR(hash_table_rehash_size,1)
2392 { /* (HASH-TABLE-REHASH-SIZE hashtable), CLtL2 p. 441, dpANS p. 18-7 */
2393 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2394 VALUES1(TheHashtable(ht)->ht_rehash_size); /* short-float REHASH-SIZE */
2395 }
2396
2397 LISPFUNNR(hash_table_rehash_threshold,1)
2398 { /* (HASH-TABLE-REHASH-THRESHOLD hashtable), CLtL2 p. 441, dpANS p. 18-8 */
2399 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2400 /* As MAKE-HASH-TABLE ignores the :REHASH-THRESHOLD argument, the value
2401 is irrelevant here and arbitrary. */
2402 VALUES1(make_SF(0,SF_exp_mid+0,(bit(SF_mant_len)/2)*3)); /* 0.75s0 */
2403 }
2404
2405 LISPFUNNR(hash_table_size,1)
2406 { /* (HASH-TABLE-SIZE hashtable), CLtL2 p. 441, dpANS p. 18-9 */
2407 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2408 VALUES1(TheHashtable(ht)->ht_maxcount); /* Fixnum MAXCOUNT */
2409 }
2410
2411 LISPFUNNR(hash_table_warn_if_needs_rehash_after_gc,1)
2412 { /* (HASH-TABLE-WARN-IF-NEEDS-REHASH-AFTER-GC hashtable) */
2413 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2414 VALUES_IF(record_flags(TheHashtable(ht)) & htflags_warn_gc_rehash_B);
2415 }
2416
2417 LISPFUNN(set_hash_table_warn_if_needs_rehash_after_gc,2)
2418 { /* ((SETF HASH-TABLE-WARN-IF-NEEDS-REHASH-AFTER-GC) val hashtable) */
2419 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2420 var bool warn_p = !nullp(popSTACK());
2421 if (warn_p)
2422 record_flags_set(TheHashtable(ht),htflags_warn_gc_rehash_B);
2423 else
2424 record_flags_clr(TheHashtable(ht),htflags_warn_gc_rehash_B);
2425 VALUES_IF(warn_p);
2426 }
2427
2428 /* return the hash table symbol
2429 or cons (test . hash) for user-defined ht_test
2430 can trigger GC - for user-defined ht_test */
hash_table_test(object ht)2431 global maygc object hash_table_test (object ht) {
2432 var uintB test_code = ht_test_code(record_flags(TheHashtable(ht)));
2433 switch (test_code) {
2434 case htflags_test_eq_B:
2435 { return S(fasthash_eq); }
2436 case htflags_test_eq_B | htflags_stablehash_B:
2437 { return S(stablehash_eq); }
2438 case htflags_test_eql_B:
2439 { return S(fasthash_eql); }
2440 case htflags_test_eql_B | htflags_stablehash_B:
2441 { return S(stablehash_eql); }
2442 case htflags_test_equal_B:
2443 { return S(fasthash_equal); }
2444 case htflags_test_equal_B | htflags_stablehash_B:
2445 { return S(stablehash_equal); }
2446 case htflags_test_equalp_B:
2447 { return S(equalp); }
2448 case bit(2): { /* user-defined ==> (test . hash) */
2449 pushSTACK(ht);
2450 var object ret = allocate_cons();
2451 ht = popSTACK();
2452 Car(ret) = TheHashtable(ht)->ht_test;
2453 Cdr(ret) = TheHashtable(ht)->ht_hash;
2454 /* should we do this at all? */
2455 /*if (subrp(Car(ret))) Car(ret) = TheSubr(Car(ret))->name;
2456 if (subrp(Cdr(ret))) Cdr(ret) = TheSubr(Cdr(ret))->name;*/
2457 return ret;
2458 }
2459 default: NOTREACHED;
2460 }
2461 }
2462
2463 LISPFUNNF(hash_table_test,1)
2464 { /* (HASH-TABLE-TEST hashtable), CLtL2 p. 441, dpANS p. 18-9 */
2465 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2466 VALUES1(hash_table_test(ht)); /* symbol as value */
2467 }
2468
2469 /* (SYSTEM::FASTHASH-STABLE-P obj)
2470 tests whether obj's FASTHASH-EQ hash code is stable across GCs. */
2471 LISPFUNNF(fasthash_stable_p,1)
2472 {
2473 var object obj = popSTACK();
2474 VALUES_IF(gcinvariant_hashcode1_p(obj));
2475 }
2476
2477 /* (SYSTEM::STABLEHASH-STABLE-P obj)
2478 tests whether obj's STABLEHASH-EQ hash code is stable across GCs. */
2479 LISPFUNNR(stablehash_stable_p,1)
2480 {
2481 var object obj = popSTACK();
2482 VALUES_IF(gcinvariant_hashcode1stable_p(obj));
2483 }
2484
2485 /* auxiliary functions for WITH-HASH-TABLE-ITERATOR, CLTL2 p. 439:
2486 (SYSTEM::HASH-TABLE-ITERATOR hashtable) returns an internal state
2487 for iterating through a hash-table.
2488 (SYSTEM::HASH-TABLE-ITERATE internal-state) iterates through a hash-table
2489 by one, thereby changes internal-state and returns: 3 values
2490 T, key, value of the next hash-table-entry resp. 1 value NIL at the end. */
2491
2492 LISPFUNNR(hash_table_iterator,1) {
2493 var object ht = check_hashtable(STACK_0); /* hashtable argument */
2494 /* An internal state consists of the key-value-vector and an index. */
2495 STACK_0 = TheHashtable(ht)->ht_kvtable; /* key-value-vector */
2496 var object maxcount = TheHashtable(ht)->ht_maxcount; /* maxcount */
2497 var object state = allocate_cons();
2498 Car(state) = popSTACK(); /* key-value-vector as car */
2499 Cdr(state) = maxcount; /* maxcount as cdr */
2500 VALUES1(state); /* state as value */
2501 }
2502
2503 LISPFUNN(hash_table_iterate,1) {
2504 var object state = popSTACK(); /* internal state */
2505 if (consp(state)) { /* hopefully a cons */
2506 var object table = Car(state); /* key-value-vector */
2507 while (1) {
2508 var uintL index = posfixnum_to_V(Cdr(state));
2509 if (index==0) /* index=0 -> no more elements */
2510 break;
2511 Cdr(state) = fixnum_inc(Cdr(state),-1); /* decrement index */
2512 var gcv_object_t* KVptr = &TheHashedAlist(table)->hal_data[3*index-3];
2513 if (!eq(KVptr[0],leer)) { /* Key /= "leer" ? */
2514 VALUES3(T,
2515 KVptr[0], /* key as the 2nd value */
2516 KVptr[1]); /* value as the 3rd value */
2517 return;
2518 }
2519 }
2520 }
2521 VALUES1(NIL); return; /* 1 value NIL */
2522 }
2523
2524 LISPFUNNR(hash_table_weak_p,1)
2525 { /* (EXT:HASH-TABLE-WEAK-P ht) */
2526 var object ht = check_hashtable(popSTACK()); /* hashtable argument */
2527 VALUES1(hash_table_weak_type(ht));
2528 }
2529
2530 LISPFUNN(set_hash_table_weak_p,2)
2531 { /* ((SETF HASH-TABLE-WEAK-P) weak-p ht) */
2532 STACK_0 = check_hashtable(STACK_0);
2533 var object val = check_weak(STACK_1); /* weak-p */
2534 var object ht = STACK_0; /* hashtable argument */
2535 if (!eq(val,hash_table_weak_type(ht))) {
2536 var uintL maxcount = posfixnum_to_V(TheHashtable(ht)->ht_maxcount);
2537 var object new_kvt;
2538 for (;;) {
2539 new_kvt = allocate_kvt(val,maxcount);
2540 /* Check whether the hash-table has not been resized during
2541 allocate_kvt(). */
2542 var uintL new_maxcount =
2543 posfixnum_to_V(TheHashtable(STACK_0)->ht_maxcount);
2544 if (maxcount == new_maxcount)
2545 break;
2546 maxcount = new_maxcount;
2547 }
2548 ht = STACK_0;
2549 var object old_kvt = TheHashtable(ht)->ht_kvtable;
2550 copy_mem_o(&TheHashedAlist(new_kvt)->hal_data[0],
2551 &TheHashedAlist(old_kvt)->hal_data[0],
2552 3*maxcount);
2553 TheHashedAlist(new_kvt)->hal_itable = TheHashedAlist(old_kvt)->hal_itable;
2554 TheHashedAlist(new_kvt)->hal_count = TheHashedAlist(old_kvt)->hal_count;
2555 TheHashedAlist(new_kvt)->hal_freelist = TheHashedAlist(old_kvt)->hal_freelist;
2556 TheHashtable(ht)->ht_kvtable = new_kvt;
2557 }
2558 VALUES1(hash_table_weak_type(ht)); skipSTACK(2);
2559 }
2560
2561 LISPFUNN(class_gethash,2)
2562 {/* (CLOS::CLASS-GETHASH ht object) is like (GETHASH (CLASS-OF object) ht). */
2563 var object ht = check_hashtable(STACK_1); /* hashtable argument */
2564 C_class_of(); /* value1 := (CLASS-OF object) */
2565 var object clas = value1;
2566 if (!ht_validp(TheHashtable(ht))) /* hash-table must still be reorganized */
2567 ht = rehash(ht);
2568 {
2569 var uint32 code = /* calculate hashcode1stable of the class */
2570 posfixnum_to_V(TheClass(clas)->hashcode);
2571 var uintL hashindex;
2572 divu_3232_3232(code,TheHashtable(ht)->ht_size, (void),hashindex = );
2573 var object kvtable = TheHashtable(ht)->ht_kvtable;
2574 var gcv_object_t* Nptr = /* pointer to the current entry */
2575 &TheSvector(TheHashedAlist(kvtable)->hal_itable)->data[hashindex];
2576 var gcv_object_t* kvt_data = TheHashedAlist(kvtable)->hal_data;
2577 while (!eq(*Nptr,nix)) { /* track "list" : "list" finished -> not found */
2578 var uintL index = posfixnum_to_V(*Nptr); /* next index */
2579 var gcv_object_t* KVptr = /* pointer to entries in key-value-vector */
2580 kvt_data + 3*index;
2581 /* compare key */
2582 if (eq(KVptr[0],clas)) {
2583 /* found */
2584 VALUES2(KVptr[1], T); goto done;
2585 }
2586 Nptr = &KVptr[2]; /* pointer to index of next entry */
2587 }
2588 /* not found */
2589 VALUES2(NIL, NIL); /* NIL as the 2nd value */
2590 }
2591 done:
2592 skipSTACK(1);
2593 }
2594
2595 /* (CLOS::CLASS-TUPLE-GETHASH ht object1 ... objectn)
2596 is like (GETHASH (funcall (hash-tuple-function n) class1 ... classn) ht)
2597 with classi = (CLASS-OF objecti).
2598 Definition: n>0, ht is a STABLEHASH-EQUAL-hashtable and
2599 (hash-tuple-function n) is defined in clos.lisp .
2600 This function is the core of the dispatch for generic functions. It has to
2601 be fast and must not cons.
2602
2603 For 1 < n <= 16,
2604 (hash-tuple-function n ...) =
2605 (cons (hash-tuple-function n1 ...) (hash-tuple-function n2 ...)) */
2606 local const uintC tuple_half_1 [17] = {0,0,1,1,2,2,2,3,4,4,4,4,4,5,6,7,8};
2607 local const uintC tuple_half_2 [17] = {0,0,1,2,2,3,4,4,4,5,6,7,8,8,8,8,8};
2608
2609 /* auxiliary function: hashcode of a series of atoms, as if they were
2610 consed together via (hash-tuple-function n) : */
hashcode_tuple(uintC n,const gcv_object_t * args_pointer,uintC depth)2611 local uint32 hashcode_tuple (uintC n, const gcv_object_t* args_pointer,
2612 uintC depth) {
2613 if (n==1) {
2614 var object clas = Next(args_pointer);
2615 return posfixnum_to_V(TheClass(clas)->hashcode); /* hashcode3stable_atom for classes */
2616 } else if (n<=16) {
2617 var uintC n1 = tuple_half_1[n];
2618 var uintC n2 = tuple_half_2[n]; /* n1 + n2 = n */
2619 var uint32 code1 = hashcode_tuple(n1,args_pointer,depth+1);
2620 var uint32 code2 = hashcode_tuple(n2,args_pointer STACKop -(uintP)n1,
2621 depth+1);
2622 switch (depth) {
2623 case 0: code1 = rotate_left(16,code1); break;
2624 case 1: code1 = rotate_left(7,code1); break; /* cf. hashcode3_cons3 */
2625 case 2: code1 = rotate_left(5,code1); break; /* cf. hashcode3_cons2 */
2626 case 3: code1 = rotate_left(3,code1); break; /* cf. hashcode3_cons1 */
2627 default: NOTREACHED;
2628 }
2629 return code1 ^ code2;
2630 } else { /* n>16, depth=0 */
2631 var uint32 code1 = hashcode_tuple(8,args_pointer,1);
2632 var uint32 code2 = hashcode_tuple(4,args_pointer STACKop -8,2);
2633 var uint32 code3 = hashcode_tuple(2,args_pointer STACKop -12,3);
2634 var uint32 code4 = hashcode_tuple(1,args_pointer STACKop -14,4);
2635 var uint32 code = 1; /* cf. hashcode3_cons0 */
2636 code = rotate_left(3,code4) ^ code; /* cf. hashcode3_cons1 */
2637 code = rotate_left(5,code3) ^ code; /* cf. hashcode3_cons2 */
2638 code = rotate_left(7,code2) ^ code; /* cf. hashcode3_cons3 */
2639 code = rotate_left(16,code1) ^ code;
2640 return code;
2641 }
2642 }
2643 /* auxiliary function: Comparison of an object with a series of atoms, as if
2644 they were consed together via (hash-tuple-function n) : */
equal_tuple(object obj,uintC n,const gcv_object_t * args_pointer)2645 local bool equal_tuple (object obj, uintC n, const gcv_object_t* args_pointer) {
2646 if (n==1) {
2647 if (eq(obj,Next(args_pointer)))
2648 return true;
2649 else
2650 return false;
2651 } else if (n<=16) {
2652 if (consp(obj)) {
2653 var uintC n1 = tuple_half_1[n];
2654 var uintC n2 = tuple_half_2[n]; /* n1 + n2 = n */
2655 if (equal_tuple(Car(obj),n1,args_pointer)
2656 && equal_tuple(Cdr(obj),n2,args_pointer STACKop -(uintP)n1)
2657 )
2658 return true;
2659 }
2660 return false;
2661 } else { /* n>16 */
2662 if (consp(obj) && equal_tuple(Car(obj),8,args_pointer)) {
2663 obj = Cdr(obj);
2664 if (consp(obj) && equal_tuple(Car(obj),4,args_pointer STACKop -8)) {
2665 obj = Cdr(obj);
2666 if (consp(obj) && equal_tuple(Car(obj),2,args_pointer STACKop -12)) {
2667 obj = Cdr(obj);
2668 n-=14; args_pointer skipSTACKop -14;
2669 /* compare obj with a list of additional atoms: */
2670 dotimespC(n,n, {
2671 if (!(consp(obj) && eq(Car(obj),Next(args_pointer))))
2672 return false;
2673 obj = Cdr(obj); args_pointer skipSTACKop -1;
2674 });
2675 if (nullp(obj))
2676 /* comparison yields true */
2677 return true;
2678 }
2679 }
2680 }
2681 return false;
2682 }
2683 }
2684
2685 LISPFUN(class_tuple_gethash,seclass_default,2,0,rest,nokey,0,NIL) {
2686 argcount++; rest_args_pointer skipSTACKop 1; /* arguments: ht {object}+ */
2687 /* first apply CLASS-OF to each argument: */
2688 {
2689 var gcv_object_t* arg_pointer = rest_args_pointer;
2690 var uintC count;
2691 dotimespC(count,argcount, {
2692 pushSTACK(Next(arg_pointer)); C_class_of(); /* (CLASS-OF arg) */
2693 NEXT(arg_pointer) = value1; /* =: arg */
2694 });
2695 }
2696 var object ht = check_hashtable(Before(rest_args_pointer));
2697 if (!ht_validp(TheHashtable(ht))) /* hash-table must still be reorganized */
2698 ht = rehash(ht);
2699 {
2700 var uint32 code = /* calculate hashcode of the cons-tree */
2701 hashcode_tuple(argcount,rest_args_pointer,0);
2702 var uintL hashindex;
2703 divu_3232_3232(code,TheHashtable(ht)->ht_size, (void),hashindex = );
2704 var object kvtable = TheHashtable(ht)->ht_kvtable;
2705 var gcv_object_t* Nptr = /* pointer to the current entry */
2706 &TheSvector(TheHashedAlist(kvtable)->hal_itable)->data[hashindex];
2707 var gcv_object_t* kvt_data = TheHashedAlist(kvtable)->hal_data;
2708 while (!eq(*Nptr,nix)) { /* track "list" : "list" finished -> not found */
2709 var uintL index = posfixnum_to_V(*Nptr); /* next index */
2710 var gcv_object_t* KVptr = /* pointer to entries in key-value-vector */
2711 kvt_data + 3*index;
2712 if (equal_tuple(KVptr[0],argcount,rest_args_pointer)) { /* compare key */
2713 /* found */
2714 VALUES1(KVptr[1]); goto done; /* Value as value */
2715 }
2716 Nptr = &KVptr[2]; /* pointer to index of next entry */
2717 }
2718 }
2719 /* not found */
2720 VALUES1(NIL);
2721 done:
2722 set_args_end_pointer(rest_args_pointer STACKop 1); /* clean up STACK */
2723 }
2724
2725 /* UP: Calculates a portable EQUAL-hashcode of an object, subject to the
2726 restriction of clause 2 in ANSI-CL:
2727 For any two objects, x and y, both of which are bit vectors,
2728 characters, conses, numbers, pathnames, strings, or symbols, and which
2729 are similar, (sxhash x) and (sxhash y) yield the same mathematical
2730 value even if x and y exist in different Lisp images of the same
2731 implementation.
2732 sxhash_clause2(obj)
2733 It is valid only until the next modification of the object.
2734 (equal X Y) implies (= (sxhash_clause2 X) (sxhash_clause2 Y)).
2735 > obj: an object
2736 < result: hashcode, a 32-bit-number */
2737 local uint32 sxhash_clause2 (object obj);
2738 /* auxiliary functions for known type:
2739 atom -> differentiate by type */
sxhash_atom(object obj,int level)2740 local uint32 sxhash_atom (object obj, int level) {
2741 unused(level); /* recursion is possible only on conses, not HTs & arrays */
2742 #ifdef TYPECODES
2743 switch (typecode(obj)) /* per type */
2744 #else
2745 if (orecordp(obj)) {
2746 if (Record_type(obj) < rectype_longlimit)
2747 goto case_orecord;
2748 else
2749 goto case_lrecord;
2750 } else if (consp(obj))
2751 goto case_cons;
2752 else if (charp(obj))
2753 goto case_char;
2754 else if (fixnump(obj))
2755 goto case_fixnum;
2756 else if (short_float_p(obj))
2757 goto case_sfloat;
2758 else if (immsubrp(obj))
2759 goto case_subr;
2760 else if (machinep(obj))
2761 goto case_machine;
2762 else if (small_read_label_p(obj) || systemp(obj))
2763 goto case_system;
2764 else switch (0)
2765 #endif
2766 {
2767 case_symbol: /* symbol */
2768 /* utilize printname
2769 (not the home-package, because it is changed on UNINTERN) */
2770 return hashcode_string(Symbol_name(obj))+0x339B0E4CUL;
2771 case_cons:
2772 default:
2773 /* address may not be used, only utilize the type */
2774 #ifdef TYPECODES
2775 return highlow32(typecode(obj),0xDABE); /*typeinfo*2^16+identification*/
2776 #else
2777 return highlow32((as_oint(obj)>>oint_type_shift)&(oint_type_mask>>oint_type_shift),0xDABE); /* typeinfo*2^16+identification */
2778 #endif
2779 case_bvector: /* bit-vector */
2780 case_b2vector: /* 2bit-vector */
2781 case_b4vector: /* 4bit-vector */
2782 case_b8vector: /* 8bit-vector */
2783 case_b16vector: /* 16bit-vector */
2784 case_b32vector: /* 32bit-vector */
2785 /* bit-vector-content */
2786 return hashcode_bvector(obj);
2787 case_string: /* string */
2788 /* string-content */
2789 return hashcode_string(obj);
2790 case_svector: /* simple-vector */
2791 /* only utilize the length */
2792 return Svector_length(obj) + 0x4ECD0A9FUL;
2793 case_ovector: /* (vector t) */
2794 case_mdarray: /* common array */
2795 /* multi-dimensional array -> utilize only rank */
2796 return Iarray_rank(obj) + 0xAAFAFAAEUL;
2797 case_structure: /* structure */
2798 /* utilize only structure-type (Liste (name_1 name_2 ... name_n)) */
2799 check_SP();
2800 return sxhash_clause2(TheStructure(obj)->structure_types) + 0xAD2CD2AEUL;
2801 case_stream: /* stream */
2802 /* utilize only streamtype */
2803 return TheStream(obj)->strmtype + 0x3DAEAE55UL;
2804 {var uint32 bish_code;
2805 case_closure: /* closure */
2806 if (Closure_instancep(obj)) goto instance_only_class;
2807 /* utilize all elements ?? */
2808 bish_code = 0xB0DD939EUL; goto record_all;
2809 case_orecord: { /* OtherRecord */
2810 /* utilize record-type, also:
2811 package: utilize package-name verwerten (not quite OK, as a
2812 package can be renamed with RENAME-PACKAGE!)
2813 pathname, byte, loadtimeeval: utilize all components
2814 hash-table, readtable, random-state, symbol-macro: nothing else */
2815 var sintB rectype = Record_type(obj);
2816 switch (rectype) {
2817 case_Rectype_Symbol_above;
2818 case_Rectype_bvector_above;
2819 case_Rectype_b2vector_above;
2820 case_Rectype_b4vector_above;
2821 case_Rectype_b8vector_above;
2822 case_Rectype_b16vector_above;
2823 case_Rectype_b32vector_above;
2824 case_Rectype_string_above;
2825 case_Rectype_Svector_above;
2826 case_Rectype_ovector_above;
2827 case_Rectype_mdarray_above;
2828 case_Rectype_Structure_above;
2829 case_Rectype_Stream_above;
2830 case_Rectype_Closure_above;
2831 case_Rectype_Instance_above;
2832 case_Rectype_Bignum_above;
2833 case_Rectype_Ffloat_above;
2834 case_Rectype_Dfloat_above;
2835 case_Rectype_Lfloat_above;
2836 case_Rectype_Ratio_above;
2837 case_Rectype_Complex_above;
2838 case_Rectype_Subr_above;
2839 default: ;
2840 }
2841 bish_code = 0xB04D939EUL + rectype;
2842 switch (rectype) {
2843 case Rectype_Package: { /* package */
2844 /* utilize package-name */
2845 var uint32 next_code = hashcode_string(ThePackage(obj)->pack_name);
2846 return rotate_left(1,next_code) + bish_code;
2847 }
2848 case Rectype_Fsubr: /* fsubr */
2849 /* utilize name */
2850 check_SP(); return sxhash_clause2(TheFsubr(obj)->name) + 0xFF3319BAUL;
2851 case Rectype_Pathname: /* pathname */
2852 case Rectype_Logpathname: /* log pathname */
2853 case Rectype_Byte: /* byte */
2854 case Rectype_Loadtimeeval: /* loadtimeeval */
2855 goto record_all;
2856 default:
2857 return bish_code;
2858 }
2859 }
2860 record_all:
2861 /* record, in which all elements can be utilized */
2862 check_SP();
2863 {
2864 var gcv_object_t* ptr = &TheRecord(obj)->recdata[0];
2865 var uintC count = SXrecord_length(obj);
2866 dotimespC(count,count, {
2867 /* combine hashcode of the next component: */
2868 var uint32 next_code = sxhash_clause2(*ptr++);
2869 bish_code = misch(bish_code,next_code);
2870 });
2871 return bish_code;
2872 }
2873 }
2874 instance_only_class:
2875 case_instance: { /* instance */
2876 /* utilize only the class */
2877 var object obj_forwarded = obj;
2878 instance_un_realloc(obj_forwarded);
2879 /*instance_update(obj,obj_forwarded); - not needed since we don't access a slot */
2880 var object cv = TheInstance(obj_forwarded)->inst_class_version;
2881 var object objclass = TheClassVersion(cv)->cv_newest_class;
2882 var object objclassname = TheClass(objclass)->classname;
2883 return sxhash_clause2(objclassname) + 0x61EFA249;
2884 }
2885 case_lrecord: /* Long-Record */
2886 /* utilize record-type and length */
2887 return 0x8CAA9057UL + (Record_type(obj) << 24) + Lrecord_length(obj);
2888 case_char: /* character */
2889 /* take EQ-hashcode (for characters EQUAL == EQL == EQ) */
2890 return hashcode1(obj);
2891 case_subr: /* SUBR */
2892 /* utilize name */
2893 check_SP(); return sxhash_clause2(TheSubr(obj)->name) + 0xFF3319BAUL;
2894 case_machine: /* machine-pointer */
2895 case_system: /* frame-pointer, small-read-label, system */
2896 /* utilize address */
2897 return hashcode1(obj);
2898 /* numbers: according to content, like with EQL */
2899 case_fixnum: /* fixnum */
2900 return hashcode_fixnum(obj);
2901 case_bignum: /* bignum */
2902 return hashcode_bignum(obj);
2903 case_sfloat: /* short-float */
2904 return hashcode_sfloat(obj);
2905 case_ffloat: /* single-float */
2906 return hashcode_ffloat(obj);
2907 case_dfloat: /* double-float */
2908 return hashcode_dfloat(obj);
2909 case_lfloat: /* Long-Float */
2910 return hashcode_lfloat(obj);
2911 case_ratio: { /* ratio */
2912 /* hash both components, mix */
2913 var uint32 code1 = sxhash_clause2(TheRatio(obj)->rt_num);
2914 var uint32 code2 = sxhash_clause2(TheRatio(obj)->rt_den);
2915 return misch(code1,code2);
2916 }
2917 case_complex: { /* complex */
2918 /* hash both components, mix */
2919 var uint32 code1 = sxhash_clause2(TheComplex(obj)->c_real);
2920 var uint32 code2 = sxhash_clause2(TheComplex(obj)->c_imag);
2921 return misch(code1,code2);
2922 }
2923 }
2924 }
sxhash_clause2(object obj)2925 local uint32 sxhash_clause2 (object obj)
2926 {
2927 return hashcode_tree(obj,0,sxhash_atom);
2928 }
2929
2930 /* UP: Calculates a portable EQUAL-hashcode of an object.
2931 sxhash(obj)
2932 It is valid only until the next modification of the object.
2933 (equal X Y) implies (= (sxhash X) (sxhash Y)).
2934 > obj: an object
2935 < result: hashcode, a 32-bit-number */
sxhash(object obj)2936 local uint32 sxhash (object obj)
2937 {
2938 /* For objects that are listed in clause 2: Use sxhash_clause2.
2939 For objects that are not listed in clause 2:
2940 - For instances of STANDARD-OBJECT or STRUCTURE-OBJECT,
2941 we can use hashcode1stable.
2942 - For other objects, we cannot use hashcode1 because it would be
2943 valid only until the next GC. So use sxhash_clause2 instead. */
2944 if (instancep(obj) || structurep(obj)) {
2945 return hashcode1stable(obj);
2946 } else {
2947 return sxhash_clause2(obj);
2948 }
2949 }
2950
2951 LISPFUNN(sxhash,1)
2952 { /* (SXHASH object), CLTL p. 285 */
2953 var uint32 sx = sxhash(popSTACK());
2954 /* ANSI CL (SXHASH doc):
2955 For any two objects, x and y, both of which are bit vectors,
2956 characters, conses, numbers, pathnames, strings, or symbols, and which
2957 are similar, (sxhash x) and (sxhash y) yield the same mathematical
2958 value even if x and y exist in different Lisp images of the same
2959 implementation.
2960 This might be interpreted - assuming that CLISP on Tru64 and CLISP on Win32
2961 are the same implementations - that (SXHASH (1- (ASH 1 32))) should return
2962 the same value both on 32-bit platforms (where 4294967295 is a bignum)
2963 and on 64-bit platforms (where is is a fixnum).
2964 On 32-bit platforms, hashcode_bignum() is used (returns 3 ==> 3).
2965 On 64-bit platforms, hashcode_fixnum() is used (returns 4294967175 ==> 135).
2966 Therefore, limiting ourselves to 24 bits on all platforms
2967 does not buy us anything anyway. */
2968 #if oint_data_len >= 32
2969 VALUES1(fixnum(sx));
2970 #elif oint_data_len >= 24
2971 sx = sx % 0xFFFFFF;
2972 VALUES1(fixnum(sx));
2973 #else
2974 #error sxhash results do not fit in a fixnum
2975 #endif
2976 }
2977
2978