/src/hashtabl.d
D | 2963 lines | 2248 code | 93 blank | 622 comment | 348 complexity | c09f40476e14e66475816b187752819e MD5 | raw file
Possible License(s): LGPL-2.0, GPL-2.0, BSD-3-Clause
Large files files are truncated, but you can click here to view the full file
- /*
- * Hash-Tables in CLISP
- * Bruno Haible 1990-2005
- * Sam Steingold 1998-2008
- * German comments translated into English: Stefan Kain 2002-01-29
- */
- #include "lispbibl.c"
- #include "arilev0.c" /* for Hashcode-Calculation */
- #include "aridecl.c" /* for Short-Floats */
- /* Structure of a Hash-Table:
- Pairs (Key . Value) are stored in a vector,
- which is indexed by (hashcode Key).
- For a running MAPHASH to be uninfluenced by a GC, this
- vector is not reorganized because of GC. But as every (hashcode key) can
- change on each GC, we build in an additional indexing-level:
- (hashcode Key) indexes an index-vector; an index points into the
- key-value-vector there, and the (key . value) is located there.
- In order to save memory, we do not store a cons (key . value)
- in the vector, but we simply store key and value consecutively.
- One might want to resolve collisions [several keys have the same
- (hascode Key)] with lists. Due to the fact that the key-value-vector
- (again because of MAPHASH) should be uninfluenced on GC and GC changes
- the set of collisions, we need an additional index-vector,
- called the next-vector, which is interlaced with the key-value-vector
- and which contains a "list"-structure.
- sketch:
- key --> (hashcode key) as index in index-vector.
- Key1 --> 3, Key2 --> 1, Key4 --> 3.
- index-vector #( nix {indexkey2} nix {indexkey1,indexkey4} nix ... )
- = #( nix 1 nix 0 nix ... )
- next-vector #( 3 nix leer nix leer)
- key-value-vector #( key1 val1 3 key2 val2 nix leer leer leer key4 val4 nix leer leer leer)
- access to a (Key . Value) - pair works as follows:
- index := (aref Index-Vektor (hashcode Key))
- until index = nix
- if (eql Key (aref KVVektor 3*index)) return (aref KVVektor 3*index+1)
- index := (aref Next-Vektor index) ; take "CDR" of the list
- = (aref KVVektor 3*index+2)
- return notfound.
- If the index-vector is enlarged, all hashcodes and the content of
- index-vector and the content of next-vector have to be recalculated.
- If the next-vector and key-value-vector are enlarged, the remaining
- elements can be filled with "leer" , without having to calculate
- a new hashcode.
- In order to have a fast MAPHASH following a CLRHASH or multiple REMHASH,
- when the table contains much fewer elements than its capacity,
- the entries could be kept "left-aligned" in the key-value-vector, i.e.
- all "leer" go to the right. Thus, MAPHASH only needs to graze over the
- elements count-1,...,1,0 of the key-value-vector. But REMHASH must
- - after it has created a gap - copy the last key-value-pair
- (Nummer count-1) into the gap.
- We treat such cases by possibly shrinking the key-value-vector and
- the next-vector on CLRHASH and REMHASH.
- We keep the "leer"-entries in next-vector in a free-"list", so that PUTHASH
- finds a free entry.
- The lengths of index-vector and next-vector do not depend on each other.
- We choose the ratio of their lengths to be 2:1.
- The hash-table is enlarged, when the free-list is empty, i.e.
- COUNT becomes greater than MAXCOUNT. Thereby, MAXCOUNT and SIZE are
- multiplied by REHASH-SIZE (>1).
- The hash-table is reduced, when COUNT < MINCOUNT. Thereby,
- MAXCOUNT and SIZE are multiplied with 1/REHASH-SIZE (<1) . We choose
- MINCOUNT = MAXCOUNT / REHASH-SIZE^2, so that COUNT can vary
- in both directions by the same amount (on a logarithmic scale)
- after the enlargement of the table.
- data-structure of the hash-table (see LISPBIBL.D):
- recflags codes the type and the state of the hash-table:
- Bit 0..3 encode the test and the hash-code function
- Bit 4..6 are state used to emit warnings for not GC-invariant keys
- Bit 7 set, when table must be reorganized after GC
- ht_size uintL>0 = length of the ITABLE
- ht_maxcount Fixnum>0 = length of the NTABLE
- ht_kvtable key-value-vector, a HashedAlist or WeakHashedAlist
- with 3*MAXCOUNT data fields and
- hal_itable index-vector of length SIZE
- hal_count number of entries in the table, <=MAXCOUNT
- hal_freelist start-index of the free-list
- ht_rehash_size growth-rate on reorganization. Float >1.1
- ht_mincount_threshold ratio MINCOUNT/MAXCOUNT = 1/rehash-size^2
- ht_mincount Fixnum>=0, lower bound for COUNT
- ht_test hash-table-test - for define-hash-table-test
- ht_hash hash function - for define-hash-table-test
- entry "leer" in key-value-vector is = #<UNBOUND>.
- entry "leer" in next-vector is filled by the free-list.
- entry "nix" in index-vector and in next-vector is = #<UNBOUND>. */
- #define leer unbound
- #define nix unbound
- #define HT_GOOD_P(ht) \
- (posfixnump(TheHashtable(ht)->ht_maxcount) && \
- posfixnump(TheHashtable(ht)->ht_mincount))
- /* ============================ Hash functions ============================ */
- /* Rotates a hashcode x by n bits to the left (0<n<32).
- rotate_left(n,x) */
- #define rotate_left(n,x) (((x) << (n)) | ((x) >> (32-(n))))
- /* mixes two hashcodes.
- one is rotated by 5 bits, then the other one is XOR-ed to it. */
- #define misch(x1,x2) (rotate_left(5,x1) ^ (x2))
- /* ------------------------------ FASTHASH EQ ------------------------------ */
- /* UP: Calculates the FASTHASH-EQ-hashcode of an object.
- hashcode1(obj)
- It is valid only until the next GC.
- (eq X Y) implies (= (hashcode1 X) (hashcode1 Y)).
- > obj: an object
- < result: hashcode, a 32-Bit-number */
- local uint32 hashcode1 (object obj);
- #if (defined(WIDE_HARD) || defined(WIDE_SOFT)) && defined(TYPECODES)
- #define hashcode1(obj) ((uint32)untype(obj))
- #else
- #define hashcode1(obj) ((uint32)as_oint(obj)) /* address (Bits 23..0) and typeinfo */
- #endif
- /* Tests whether hashcode1 of an object is guaranteed to be GC-invariant. */
- global bool gcinvariant_hashcode1_p (object obj) {
- return gcinvariant_object_p(obj);
- }
- /* ----------------------------- STABLEHASH EQ ----------------------------- */
- /* UP: Calculates the STABLEHASH-EQ-hashcode of an object.
- hashcode1stable(obj)
- It is valid across GC for instances of STANDARD-STABLEHASH, STRUCTURE-STABLEHASH.
- (eq X Y) implies (= (hashcode1 X) (hashcode1 Y)).
- > obj: an object
- < result: hashcode, a 32-Bit-number */
- global uint32 hashcode1stable (object obj) {
- if (instancep(obj)) {
- var object obj_forwarded = obj;
- instance_un_realloc(obj_forwarded);
- /* No need for instance_update here; if someone redefines a class in
- such a way that the hashcode slot goes away, the behaviour is
- undefined. */
- var object cv = TheInstance(obj_forwarded)->inst_class_version;
- var object clas = TheClassVersion(cv)->cv_class;
- if (!nullp(TheClass(clas)->subclass_of_stablehash_p)) {
- /* The hashcode slot is known to be at position 1, thanks to
- :FIXED-SLOT-LOCATIONS. */
- return posfixnum_to_V(TheInstance(obj_forwarded)->other[0]);
- }
- } else if (structurep(obj)) {
- if (!nullp(memq(S(structure_stablehash),TheStructure(obj)->structure_types))) {
- /* The hashcode slot is known to be at position 1, thanks to the way
- slots are inherited in DEFSTRUCT. */
- return posfixnum_to_V(TheStructure(obj)->recdata[1]);
- }
- } else if (symbolp(obj)) {
- var object hashcode = TheSymbol(obj)->hashcode;
- if (eq(hashcode,unbound)) {
- /* The first access to a symbol's hash code computes it. */
- pushSTACK(unbound); C_random_posfixnum(); hashcode = value1;
- TheSymbol(obj)->hashcode = hashcode;
- }
- return posfixnum_to_V(hashcode);
- }
- return hashcode1(obj);
- }
- /* UP: Tests whether an object is instance of STANDARD-STABLEHASH or
- STRUCTURE-STABLEHASH. */
- local inline bool instance_of_stablehash_p (object obj) {
- if (instancep(obj)) {
- var object obj_forwarded = obj;
- instance_un_realloc(obj_forwarded);
- var object cv = TheInstance(obj_forwarded)->inst_class_version;
- var object clas = TheClassVersion(cv)->cv_class;
- return !nullp(TheClass(clas)->subclass_of_stablehash_p);
- } else if (structurep(obj)) {
- return !nullp(memq(S(structure_stablehash),TheStructure(obj)->structure_types));
- }
- return false;
- }
- /* Tests whether hashcode1stable of an object is guaranteed to be
- GC-invariant. */
- global bool gcinvariant_hashcode1stable_p (object obj) {
- return gcinvariant_object_p(obj)
- || instance_of_stablehash_p(obj) || symbolp(obj);
- }
- /* ----------------------------- FASTHASH EQL ----------------------------- */
- /* UP: Calculates the FASTHASH-EQL-hashcode of an object.
- hashcode2(obj)
- It is valid only until the next GC.
- (eql X Y) implies (= (hashcode2 X) (hashcode2 Y)).
- > obj: an object
- < result: hashcode, a 32-Bit-number */
- global uint32 hashcode2 (object obj);
- /* auxiliary functions for known type:
- Fixnum: fixnum-value */
- local uint32 hashcode_fixnum (object obj);
- #if 0
- local uint32 hashcode_fixnum(object obj) { return hashcode1(obj); }
- #else
- #define hashcode_fixnum(obj) hashcode1(obj)
- #endif
- /* Bignum: length*2 + all digits */
- local uint32 hashcode_bignum (object obj) {
- var uintL len = (uintL)Bignum_length(obj); /* number of Words */
- var uint32 code = 2*len;
- var uintL pos;
- #if (intDsize==32)
- for (pos=0; pos<len; pos++)
- code = misch(code,TheBignum(obj)->data[pos]);
- #elif (intDsize==16)
- var uintL len1 = len & 1; /* len mod 2 */
- var uintL len2 = len - len1; /* len div 2 */
- for (pos=0; pos<len2; pos+=2)
- code = misch(code,highlow32(TheBignum(obj)->data[pos],
- TheBignum(obj)->data[pos+1]));
- if (len1 != 0) code = misch(code,TheBignum(obj)->data[len2]); /* LSD */
- #else /* (intDsize==8) */
- var uintL len1 = len & 3; /* len mod 4 */
- var uintL len2 = len - len1; /* len div 4 */
- for (pos=0; pos<len2; pos+=4)
- code = misch(code,( (((uint32)TheBignum(obj)->data[pos]) << 24)
- |(((uint32)TheBignum(obj)->data[pos+1]) << 16)
- |(((uint32)TheBignum(obj)->data[pos+2]) << 8)
- |(((uint32)TheBignum(obj)->data[pos+3]))));
- if (len1 != 0) {
- var uint32 lsd=0;
- for (pos=0; pos<len1; pos++)
- lsd |= ((uint32)TheBignum(obj)->data[len2+pos]) << (pos<<3);
- code = misch(code,lsd);
- }
- #endif
- return code;
- }
- /* Short-Float: internal representation */
- local uint32 hashcode_sfloat (object obj);
- #if 0
- local uint32 hashcode_sfloat(object obj) { return hashcode1(obj); }
- #else
- #define hashcode_sfloat(obj) hashcode1(obj)
- #endif
- /* Single-Float: 32 Bit */
- local uint32 hashcode_ffloat (object obj) {
- return ffloat_value(obj);
- }
- /* Double-Float: leading 32 Bits */
- local uint32 hashcode_dfloat (object obj) {
- #ifdef intQsize
- return (uint32)(TheDfloat(obj)->float_value >> 32);
- #else
- return TheDfloat(obj)->float_value.semhi;
- #endif
- }
- /* Long-Float: mixture of exponent, length, first 32 bits */
- extern uint32 hashcode_lfloat (object obj); /* see LFLOAT.D */
- /* in general: */
- global uint32 hashcode2 (object obj) {
- #ifdef TYPECODES
- if (!numberp(obj)) { /* a number? */
- /* no -> take EQ-hashcode (for characters, EQL == EQ) : */
- return hashcode1(obj);
- } else { /* yes -> differentiate according to typecode */
- switch (typecode(obj) & ~(bit(number_bit_t)|bit(sign_bit_t))) {
- case fixnum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Fixnum */
- return hashcode_fixnum(obj);
- case bignum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Bignum */
- return hashcode_bignum(obj);
- case sfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Short-Float*/
- return hashcode_sfloat(obj);
- case ffloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Single-Float*/
- return hashcode_ffloat(obj);
- case dfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Double-Float*/
- return hashcode_dfloat(obj);
- case lfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Long-Float */
- return hashcode_lfloat(obj);
- case ratio_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Ratio */
- /* hash both components, mix */
- var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
- var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
- return misch(code1,code2);
- }
- case complex_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Complex */
- /* hash both components, mix */
- var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
- var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
- return misch(code1,code2);
- }
- default: NOTREACHED;
- }
- }
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case Rectype_Bignum:
- return hashcode_bignum(obj);
- case Rectype_Ffloat:
- return hashcode_ffloat(obj);
- case Rectype_Dfloat:
- return hashcode_dfloat(obj);
- case Rectype_Lfloat:
- return hashcode_lfloat(obj);
- case Rectype_Ratio: { /* hash both components, mix */
- var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
- var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
- return misch(code1,code2);
- }
- case Rectype_Complex: { /* hash both components, mix */
- var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
- var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
- return misch(code1,code2);
- }
- default:
- break;
- }
- else if (immediate_number_p(obj)) {
- if (as_oint(obj) & wbit(4))
- return hashcode_sfloat(obj);
- else
- return hashcode_fixnum(obj);
- }
- return hashcode1(obj);
- #endif
- }
- /* Tests whether hashcode2 of an object is guaranteed to be GC-invariant. */
- global bool gcinvariant_hashcode2_p (object obj) {
- return numberp(obj) || gcinvariant_object_p(obj);
- }
- /* ---------------------------- STABLEHASH EQL ---------------------------- */
- /* UP: Calculates the STABLEHASH-EQL-hashcode of an object.
- hashcode2stable(obj)
- It is valid across GC for instances of STANDARD-STABLEHASH, STRUCTURE-STABLEHASH.
- (eql X Y) implies (= (hashcode2stable X) (hashcode2stable Y)).
- > obj: an object
- < result: hashcode, a 32-Bit-number */
- global uint32 hashcode2stable (object obj) {
- #ifdef TYPECODES
- if (!numberp(obj)) { /* a number? */
- /* no -> take EQ-hashcode (for characters, EQL == EQ) : */
- return hashcode1stable(obj);
- } else { /* yes -> differentiate according to typecode */
- switch (typecode(obj) & ~(bit(number_bit_t)|bit(sign_bit_t))) {
- case fixnum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Fixnum */
- return hashcode_fixnum(obj);
- case bignum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Bignum */
- return hashcode_bignum(obj);
- case sfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Short-Float*/
- return hashcode_sfloat(obj);
- case ffloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Single-Float*/
- return hashcode_ffloat(obj);
- case dfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /*Double-Float*/
- return hashcode_dfloat(obj);
- case lfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): /* Long-Float */
- return hashcode_lfloat(obj);
- case ratio_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Ratio */
- /* hash both components, mix */
- var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
- var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
- return misch(code1,code2);
- }
- case complex_type & ~(bit(number_bit_t)|bit(sign_bit_t)): { /* Complex */
- /* hash both components, mix */
- var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
- var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
- return misch(code1,code2);
- }
- default: NOTREACHED;
- }
- }
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case Rectype_Bignum:
- return hashcode_bignum(obj);
- case Rectype_Ffloat:
- return hashcode_ffloat(obj);
- case Rectype_Dfloat:
- return hashcode_dfloat(obj);
- case Rectype_Lfloat:
- return hashcode_lfloat(obj);
- case Rectype_Ratio: { /* hash both components, mix */
- var uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
- var uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
- return misch(code1,code2);
- }
- case Rectype_Complex: { /* hash both components, mix */
- var uint32 code1 = hashcode2(TheComplex(obj)->c_real);
- var uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
- return misch(code1,code2);
- }
- default:
- break;
- }
- else if (immediate_number_p(obj)) {
- if (as_oint(obj) & wbit(4))
- return hashcode_sfloat(obj);
- else
- return hashcode_fixnum(obj);
- }
- return hashcode1stable(obj);
- #endif
- }
- /* Tests whether hashcode2stable of an object is guaranteed to be
- GC-invariant. */
- global bool gcinvariant_hashcode2stable_p (object obj) {
- return numberp(obj)
- || gcinvariant_object_p(obj)
- || instance_of_stablehash_p(obj) || symbolp(obj);
- }
- /* ---------------------------- FASTHASH EQUAL ---------------------------- */
- /* UP: Calculates the FASTHASH-EQUAL-hashcode of an object.
- hashcode3(obj)
- It is valid only until the next GC, or the next modification
- of the object.
- (equal X Y) implies (= (hashcode3 X) (hashcode3 Y)).
- > obj: an object
- < result: hashcode, a 32-Bit-number */
- global uint32 hashcode3 (object obj);
- /* auxiliary functions for known type:
- String -> length + all characters */
- local uint32 hashcode_string (object obj) {
- var uintL len;
- var uintL offset;
- var object string = unpack_string_ro(obj,&len,&offset);
- var uint32 bish_code = 0x33DAE11FUL + len; /* utilize length */
- if (len > 0 && !simple_nilarray_p(string)) {
- SstringDispatch(string,X, {
- var const cintX* ptr = &((SstringX)TheVarobject(string))->data[offset];
- var uintC count = len;
- dotimespC(count,count, {
- var uint32 next_code = (uint32)(*ptr++); /* next character */
- bish_code = misch(bish_code,next_code); /* add */
- });
- });
- }
- return bish_code;
- }
- /* bit-vector -> length, first 16 bits, utilize last 16 bits */
- local uint32 hashcode_bvector (object obj) {
- var uintL len = vector_length(obj); /* length */
- var uintL index = 0;
- var object sbv = array_displace_check(obj,len,&index);
- /* sbv is the data-vector, index is the index into the data-vector. */
- len = len << sbNvector_atype(sbv);
- #if BIG_ENDIAN_P && (varobject_alignment%2 == 0)
- /* On big-endian-machines one can work with with 16 Bit at a time
- (so long as varobject_alignment is divisible by 2 byte): */
- #define bitpack 16
- #define uint_bitpack uint16
- #define get32bits_at highlow32_at
- #else
- /* else one can take only 8 bit at a time: */
- #define bitpack 8
- #define uint_bitpack uint8
- #define get32bits_at(p) \
- (((((((uint32)((p)[0])<<8)|(uint32)((p)[1]))<<8)|(uint32)((p)[2]))<<8)|(uint32)((p)[3]))
- #endif
- var uint_bitpack* ptr = /* pointer to the first used word */
- (uint_bitpack*)(&TheSbvector(sbv)->data[0]) + floor(index,bitpack);
- var uintL offset = index%bitpack; /* offset within the word */
- if (len <= 32) { /* length <= 32 -> take all bits: */
- if (len == 0) {
- return 0x8FA1D564UL;
- } else { /* 0<len<=32 */
- var uintL need = offset+len; /* need 'need' bits for now */
- /* need < 48 */
- var uint32 akku12 = 0; /* 48-Bit-Akku, part 1 and 2 */
- var uint32 akku3 = 0; /* 48-Bit-Akku, part 3 */
- #if (bitpack==16)
- if (need > 0) {
- akku12 = highlow32_0(*ptr++); /* first 16 bits */
- if (need > 16) {
- akku12 |= (uint32)(*ptr++); /* next 16 bits */
- if (need > 32)
- akku3 = (uint32)(*ptr++); /* last 16 bits */
- }
- }
- #endif
- #if (bitpack==8)
- if (need > 0) {
- akku12 = (uint32)(*ptr++)<<24; /* first 8 bits */
- if (need > 8) {
- akku12 |= (uint32)(*ptr++)<<16; /* next 8 bits */
- if (need > 16) {
- akku12 |= (uint32)(*ptr++)<<8; /* next 8 bits */
- if (need > 24) {
- akku12 |= (uint32)(*ptr++); /* next 8 bits */
- if (need > 32) {
- akku3 = (uint32)(*ptr++)<<8; /* next 8 bits */
- if (need > 40)
- akku3 |= (uint32)(*ptr++); /* last 8 bits */
- }
- }
- }
- }
- }
- #endif
- /* shift 'need' bits in akku12,akku3 by offset bits to the left: */
- akku12 = (akku12 << offset) | (uint32)high16(akku3 << offset);
- /* 32 bits in akku12 finished.
- mask out irrelevant bits: */
- akku12 = akku12 & ~(bit(32-len)-1);
- /* utilize length: */
- return akku12+len;
- }
- } else { /* length > 32 -> take first and last 16 bits: */
- var uint32 akku12 = /* 32-bit-akku */
- get32bits_at(ptr) << offset; /* contains at least the first 16 bits */
- offset += len; /* end-offset of the bitvector */
- ptr += floor(offset,bitpack); /* points to the last used word */
- offset = offset%bitpack; /* end-offset within the word */
- var uint32 akku34 = /* 32-bit-akku */
- get32bits_at(ptr-(16/bitpack)) << offset; /* contains at least the last 16 bits */
- /* reach for the first 16, last 16 bits and utilize length: */
- return highlow32(high16(akku12),high16(akku34)) + len;
- }
- #undef get32bits_at
- #undef uint_bitpack
- #undef bitpack
- }
- /* EQUALP-hashcode of a pathname-component. */
- #ifdef PATHNAME_WIN32
- global uint32 hashcode4 (object obj);
- #define hashcode_pathcomp(obj) hashcode4(obj)
- #else
- #define hashcode_pathcomp(obj) hashcode3(obj)
- #endif
- /* atom -> differentiation by type */
- local uint32 hashcode3_atom (object obj) {
- #ifdef TYPECODES
- if (symbolp(obj)) { /* a symbol? */
- return hashcode1(obj); /* yes -> take EQ-hashcode */
- } else if (numberp(obj)) { /* a number? */
- return hashcode2(obj); /* yes -> take EQL-hashcode */
- } else {
- var tint type = typecode(obj) /* typeinfo */
- & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
- if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
- && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
- return hashcode_bvector(obj); /* look at it component-wise */
- if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
- return hashcode_string(obj); /* look at it component-wise */
- if (xpathnamep(obj)) { /* -> look at it component-wise: */
- check_SP();
- var uint32 bish_code = 0xB0DD939EUL;
- var const gcv_object_t* ptr = &((Record)ThePathname(obj))->recdata[0];
- var uintC count;
- dotimespC(count,Xrecord_length(obj), {
- var uint32 next_code = hashcode_pathcomp(*ptr++); /* hashcode of the next component */
- bish_code = misch(bish_code,next_code); /* add */
- });
- return bish_code;
- }
- /* else: take EQ-hashcode (for characters: EQL == EQ) */
- return hashcode1(obj);
- }
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case_Rectype_number_above;
- case Rectype_Sbvector: case Rectype_bvector:
- case Rectype_Sb2vector: case Rectype_b2vector:
- case Rectype_Sb4vector: case Rectype_b4vector:
- case Rectype_Sb8vector: case Rectype_b8vector:
- case Rectype_Sb16vector: case Rectype_b16vector:
- case Rectype_Sb32vector: case Rectype_b32vector:
- return hashcode_bvector(obj);
- case Rectype_S8string: case Rectype_Imm_S8string:
- case Rectype_S16string: case Rectype_Imm_S16string:
- case Rectype_S32string: case Rectype_Imm_S32string:
- case Rectype_reallocstring: case Rectype_string:
- return hashcode_string(obj);
- #ifdef LOGICAL_PATHNAMES
- case Rectype_Logpathname:
- #endif
- case Rectype_Pathname: { /* pathname -> look at it component-wise: */
- check_SP();
- var uint32 bish_code = 0xB0DD939EUL;
- var gcv_object_t* ptr = &((Record)ThePathname(obj))->recdata[0];
- var uintC count;
- dotimespC(count,Xrecord_length(obj), {
- var uint32 next_code = hashcode_pathcomp(*ptr++); /* hashcode of the next component */
- bish_code = misch(bish_code,next_code); /* add */
- });
- return bish_code;
- }
- default:
- break;
- }
- else if (immediate_number_p(obj)) {
- case_number: return hashcode2(obj);
- }
- return hashcode1(obj);
- #endif
- }
- /* tree -> look at content up to depth 4, more if some paths end early
- determine the hashcode of the CAR and the hashcode of the CDR at a time
- and combine them shifted. As shifts we can choose, e.g. 16,7,5,3, because
- {0,16} + {0,7} + {0,5} + {0,3} = {0,3,5,7,8,10,12,15,16,19,21,23,24,26,28,31}
- consists of 16 different elements of {0,...,31} .
- > obj : the arbitrary object, tree(=cons) or leaf(=atom)
- > need : how many objects are still needed
- > level : the current distance from the root, to avoid circularity
- > hashcode_atom : how to compute the hash code of a leaf */
- #define HASHCODE_TREE_MAX_LEVEL 16
- #define HASHCODE_TREE_NEED_LEAVES 16
- local inline uint32 hashcode_tree_rec (object obj, int* need, int level,
- uint32 (hashcode_leaf) (object)) {
- if (atomp(obj)) {
- (*need)--;
- return hashcode_leaf(obj);
- } else if (level > HASHCODE_TREE_MAX_LEVEL || *need == 0) {
- return 1;
- } else {
- var local const uint8 shifts[4] = { 16 , 7 , 5 , 3 };
- var uint32 car_code = hashcode_tree_rec(Car(obj),need,level+1,hashcode_leaf);
- var uint32 cdr_code = *need == 0 ? 1 :
- hashcode_tree_rec(Cdr(obj),need,level+1,hashcode_leaf);
- return rotate_left(shifts[level & 3],car_code) ^ cdr_code;
- }
- }
- local inline uint32 hashcode_tree (object obj, uint32 (hashcode_leaf) (object))
- {
- int need = HASHCODE_TREE_NEED_LEAVES;
- return hashcode_tree_rec(obj,&need,0,hashcode_leaf);
- }
- /* similar to hashcode_tree
- NB: use the SAME top-level need initial value (e.g., HASHCODE_TREE_NEED_LEAVES)
- for the corresponding hashcode_tree and gcinvariant_hashcode_tree_p calls */
- local inline bool gcinvariant_hashcode_tree_p_rec
- (object obj, int* need, int level,
- bool (gcinvariant_hashcode_leaf_p) (object)) {
- if (atomp(obj)) {
- (*need)--;
- return gcinvariant_hashcode_leaf_p(obj);
- } else if (level > HASHCODE_TREE_MAX_LEVEL || *need == 0) {
- return true;
- } else {
- return gcinvariant_hashcode_tree_p_rec(Car(obj),need,level+1,
- gcinvariant_hashcode_leaf_p)
- && (*need == 0 ? true :
- gcinvariant_hashcode_tree_p_rec(Cdr(obj),need,level+1,
- gcinvariant_hashcode_leaf_p));
- }
- }
- local inline bool gcinvariant_hashcode_tree_p
- (object obj, bool (gcinvariant_hashcode_leaf_p) (object)) {
- int need = HASHCODE_TREE_NEED_LEAVES;
- return gcinvariant_hashcode_tree_p_rec(obj,&need,0,
- gcinvariant_hashcode_leaf_p);
- }
- #undef HASHCODE_TREE_MAX_LEVEL
- #undef HASHCODE_TREE_NEED_LEAVES
- global uint32 hashcode3 (object obj)
- { return hashcode_tree(obj,hashcode3_atom); }
- /* Tests whether hashcode3 of an object is guaranteed to be GC-invariant. */
- global bool gcinvariant_hashcode3_p (object obj);
- local bool gcinvariant_hashcode3_atom_p (object obj) {
- if (numberp(obj) || gcinvariant_object_p(obj))
- return true;
- #ifdef TYPECODES
- var tint type = typecode(obj) /* typeinfo */
- & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
- if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
- && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
- return true;
- if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
- return true;
- /* Ignore the pathnames, for simplicity. */
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case Rectype_Sbvector: case Rectype_bvector:
- case Rectype_Sb2vector: case Rectype_b2vector:
- case Rectype_Sb4vector: case Rectype_b4vector:
- case Rectype_Sb8vector: case Rectype_b8vector:
- case Rectype_Sb16vector: case Rectype_b16vector:
- case Rectype_Sb32vector: case Rectype_b32vector:
- case Rectype_S8string: case Rectype_Imm_S8string:
- case Rectype_S16string: case Rectype_Imm_S16string:
- case Rectype_S32string: case Rectype_Imm_S32string:
- case Rectype_reallocstring: case Rectype_string:
- return true;
- /* Ignore the pathnames, for simplicity. */
- default:
- break;
- }
- #endif
- return false;
- }
- global bool gcinvariant_hashcode3_p (object obj)
- { return gcinvariant_hashcode_tree_p(obj,gcinvariant_hashcode3_atom_p); }
- /* --------------------------- STABLEHASH EQUAL --------------------------- */
- /* UP: Calculates the STABLEHASH-EQUAL-hashcode of an object.
- hashcode3stable(obj)
- It is valid across GC if all cons-tree leaves are instances of
- STANDARD-STABLEHASH, STRUCTURE-STABLEHASH, but no longer than the next
- modification of the object.
- (equal X Y) implies (= (hashcode3stable X) (hashcode3stable Y)).
- > obj: an object
- < result: hashcode, a 32-Bit-number */
- global uint32 hashcode3stable (object obj);
- /* atom -> differentiation by type */
- local uint32 hashcode3stable_atom (object obj) {
- #ifdef TYPECODES
- if (symbolp(obj)) { /* a symbol? */
- return hashcode1stable(obj); /* yes -> take EQ-hashcode */
- } else if (numberp(obj)) { /* a number? */
- return hashcode2(obj); /* yes -> take EQL-hashcode */
- } else {
- var tint type = typecode(obj) /* typeinfo */
- & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
- if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
- && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
- return hashcode_bvector(obj); /* look at it component-wise */
- if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
- return hashcode_string(obj); /* look at it component-wise */
- if (xpathnamep(obj)) { /* -> look at it component-wise: */
- check_SP();
- var uint32 bish_code = 0xB0DD939EUL;
- var const gcv_object_t* ptr = &((Record)ThePathname(obj))->recdata[0];
- var uintC count;
- dotimespC(count,Xrecord_length(obj), {
- var uint32 next_code = hashcode_pathcomp(*ptr++); /* hashcode of the next component */
- bish_code = misch(bish_code,next_code); /* add */
- });
- return bish_code;
- }
- /* else: take EQ-hashcode (for characters: EQL == EQ) */
- return hashcode1stable(obj);
- }
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case_Rectype_number_above;
- case Rectype_Sbvector: case Rectype_bvector:
- case Rectype_Sb2vector: case Rectype_b2vector:
- case Rectype_Sb4vector: case Rectype_b4vector:
- case Rectype_Sb8vector: case Rectype_b8vector:
- case Rectype_Sb16vector: case Rectype_b16vector:
- case Rectype_Sb32vector: case Rectype_b32vector:
- return hashcode_bvector(obj);
- case Rectype_S8string: case Rectype_Imm_S8string:
- case Rectype_S16string: case Rectype_Imm_S16string:
- case Rectype_S32string: case Rectype_Imm_S32string:
- case Rectype_reallocstring: case Rectype_string:
- return hashcode_string(obj);
- #ifdef LOGICAL_PATHNAMES
- case Rectype_Logpathname:
- #endif
- case Rectype_Pathname: { /* pathname -> look at it component-wise: */
- check_SP();
- var uint32 bish_code = 0xB0DD939EUL;
- var gcv_object_t* ptr = &((Record)ThePathname(obj))->recdata[0];
- var uintC count;
- dotimespC(count,Xrecord_length(obj), {
- var uint32 next_code = hashcode_pathcomp(*ptr++); /* hashcode of the next component */
- bish_code = misch(bish_code,next_code); /* add */
- });
- return bish_code;
- }
- default:
- break;
- }
- else if (immediate_number_p(obj)) {
- case_number: return hashcode2(obj);
- }
- return hashcode1stable(obj);
- #endif
- }
- global uint32 hashcode3stable (object obj)
- { return hashcode_tree(obj,hashcode3stable_atom); }
- /* Tests whether hashcode3stable of an object is guaranteed to be
- GC-invariant. */
- global bool gcinvariant_hashcode3stable_p (object obj);
- local bool gcinvariant_hashcode3stable_atom_p (object obj) {
- if (numberp(obj) || gcinvariant_object_p(obj))
- return true;
- #ifdef TYPECODES
- var tint type = typecode(obj) /* typeinfo */
- & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
- if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
- && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
- return true;
- if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
- return true;
- /* Ignore the pathnames, for simplicity. */
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case Rectype_Sbvector: case Rectype_bvector:
- case Rectype_Sb2vector: case Rectype_b2vector:
- case Rectype_Sb4vector: case Rectype_b4vector:
- case Rectype_Sb8vector: case Rectype_b8vector:
- case Rectype_Sb16vector: case Rectype_b16vector:
- case Rectype_Sb32vector: case Rectype_b32vector:
- case Rectype_S8string: case Rectype_Imm_S8string:
- case Rectype_S16string: case Rectype_Imm_S16string:
- case Rectype_S32string: case Rectype_Imm_S32string:
- case Rectype_reallocstring: case Rectype_string:
- return true;
- /* Ignore the pathnames, for simplicity. */
- default:
- break;
- }
- #endif
- return instance_of_stablehash_p(obj) || symbolp(obj);
- }
- global bool gcinvariant_hashcode3stable_p (object obj)
- { return gcinvariant_hashcode_tree_p(obj,gcinvariant_hashcode3stable_atom_p); }
- /* ---------------------------- FASTHASH EQUALP ---------------------------- */
- /* UP: Calculates the EQUALP-hashcode of an object.
- hashcode4(obj)
- Is is valid only until the next GC or the next modification
- of the object.
- (equalp X Y) implies (= (hashcode4 X) (hashcode4 Y)). */
- global uint32 hashcode4 (object obj);
- /* auxiliary functions for known type:
- character -> case-insensitive. */
- #define hashcode4_char(c) (0xCAAEACEFUL + (uint32)as_cint(up_case(c)))
- /* number: mixture of exponent, length, first 32 bit */
- extern uint32 hashcode4_real (object obj); /* see REALELEM.D */
- extern uint32 hashcode4_uint32 (uint32 x); /* see REALELEM.D */
- extern uint32 hashcode4_uint4 [16]; /* see REALELEM.D */
- /* vectors: look at them component-wise */
- local uint32 hashcode4_vector_T (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_Char (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_Bit (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_2Bit (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_4Bit (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_8Bit (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_16Bit (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_32Bit (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector (object dv, uintL index,
- uintL count, uint32 bish_code);
- local uint32 hashcode4_vector_T (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- check_SP();
- var const gcv_object_t* ptr = &TheSvector(dv)->data[index];
- dotimespL(count,count, {
- var uint32 next_code = hashcode4(*ptr++); /* next component's hashcode */
- bish_code = misch(bish_code,next_code); /* add */
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_Char (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- SstringDispatch(dv,X, {
- var const cintX* ptr = &((SstringX)TheVarobject(dv))->data[index];
- dotimespL(count,count, {
- var uint32 next_code = hashcode4_char(as_chart(*ptr++)); /*next char*/
- bish_code = misch(bish_code,next_code); /* add */
- });
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_Bit (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- var const uintB* ptr = &TheSbvector(dv)->data[index/8];
- dotimespL(count,count, {
- var uint32 next_code =
- hashcode4_uint4[(*ptr >> ((~index)%8)) & (bit(1)-1)]; /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- index++;
- ptr += ((index%8)==0);
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_2Bit (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- var const uintB* ptr = &TheSbvector(dv)->data[index/4];
- dotimespL(count,count, {
- var uint32 next_code =
- hashcode4_uint4[(*ptr >> ((~index)%4)) & (bit(2)-1)]; /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- index++;
- ptr += ((index%4)==0);
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_4Bit (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- var const uintB* ptr = &TheSbvector(dv)->data[index/2];
- dotimespL(count,count, {
- var uint32 next_code =
- hashcode4_uint4[(*ptr >> ((~index)%2)) & (bit(4)-1)]; /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- index++;
- ptr += ((index%2)==0);
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_8Bit (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- var const uintB* ptr = &TheSbvector(dv)->data[index];
- dotimespL(count,count, {
- var uint32 next_code = hashcode4_uint32(*ptr++); /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_16Bit (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- var const uint16* ptr = &((uint16*)&TheSbvector(dv)->data[0])[index];
- dotimespL(count,count, {
- var uint32 next_code = hashcode4_uint32(*ptr++); /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector_32Bit (object dv, uintL index,
- uintL count, uint32 bish_code) {
- if (count > 0) {
- var const uint32* ptr = &((uint32*)&TheSbvector(dv)->data[0])[index];
- dotimespL(count,count, {
- var uint32 next_code = hashcode4_uint32(*ptr++); /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- });
- }
- return bish_code;
- }
- local uint32 hashcode4_vector (object dv, uintL index,
- uintL count, uint32 bish_code) {
- switch (Array_type(dv)) {
- case Array_type_svector: /* simple-vector */
- return hashcode4_vector_T(dv,index,count,bish_code);
- case Array_type_sbvector: /* simple-bit-vector */
- return hashcode4_vector_Bit(dv,index,count,bish_code);
- case Array_type_sb2vector:
- return hashcode4_vector_2Bit(dv,index,count,bish_code);
- case Array_type_sb4vector:
- return hashcode4_vector_4Bit(dv,index,count,bish_code);
- case Array_type_sb8vector:
- return hashcode4_vector_8Bit(dv,index,count,bish_code);
- case Array_type_sb16vector:
- return hashcode4_vector_16Bit(dv,index,count,bish_code);
- case Array_type_sb32vector:
- return hashcode4_vector_32Bit(dv,index,count,bish_code);
- case Array_type_snilvector: /* (VECTOR NIL) */
- if (count > 0)
- return 0x2116ECD0 + bish_code;
- /*FALLTHROUGH*/
- case Array_type_sstring: /* simple-string */
- return hashcode4_vector_Char(dv,index,count,bish_code);
- default: NOTREACHED;
- }
- }
- /* atom -> differentiation by type */
- local uint32 hashcode4_atom (object obj) {
- #ifdef TYPECODES
- if (symbolp(obj)) { /* a symbol? */
- return hashcode1(obj); /* yes -> take EQ-hashcode */
- } else if (numberp(obj)) { /* a number? */
- /* yes -> take EQUALP-hashcode */
- if (complexp(obj)) {
- var uint32 code1 = hashcode4_real(TheComplex(obj)->c_real);
- var uint32 code2 = hashcode4_real(TheComplex(obj)->c_imag);
- /* important for combining, because of "complex canonicalization":
- if imagpart=0.0, then hashcode = hashcode4_real(realpart). */
- return code1 ^ rotate_left(5,code2);
- } else {
- return hashcode4_real(obj);
- }
- } else
- switch (typecode(obj))
- #else
- if (orecordp(obj)) {
- if (Record_type(obj) < rectype_longlimit)
- goto case_orecord;
- else
- goto case_lrecord;
- } else if (immediate_number_p(obj)) {
- case_real: return hashcode4_real(obj);
- } else if (charp(obj))
- goto case_char;
- else
- return hashcode1(obj);
- switch (0)
- #endif
- {
- case_bvector: /* bit-vector */
- case_b2vector: /* 2bit-vector */
- case_b4vector: /* 4bit-vector */
- case_b8vector: /* 8bit-vector */
- case_b16vector: /* 16bit-vector */
- case_b32vector: /* 32bit-vector */
- case_string: /* string */
- case_vector: { /* (VECTOR T), (VECTOR NIL) */
- /* look at it component-wise: */
- var uintL len = vector_length(obj); /* length */
- var uintL index = 0;
- var object dv = array_displace_check(obj,len,&index);
- /* dv is the data-vector, index is the index into the data-vector. */
- var uint32 bish_code = 0x724BD24EUL + len; /* utilize length */
- return hashcode4_vector(dv,index,len,bish_code);
- }
- case_mdarray: { /* array with rank /=1 */
- /* rank and dimensions, then look at it component-wise: */
- var uint32 bish_code = 0xF1C90A73UL;
- {
- var uintC rank = Iarray_rank(obj);
- if (rank > 0) {
- var uintL* dimptr = &TheIarray(obj)->dims[0];
- if (Iarray_flags(obj) & bit(arrayflags_dispoffset_bit))
- dimptr++;
- dotimespC(rank,rank, {
- var uint32 next_code = (uint32)(*dimptr++);
- bish_code = misch(bish_code,next_code);
- });
- }
- }
- {
- var uintL len = TheIarray(obj)->totalsize;
- var uintL index = 0;
- var object dv = iarray_displace_check(obj,len,&index);
- return hashcode4_vector(dv,index,len,bish_code);
- }
- }
- #ifdef TYPECODES
- _case_structure
- _case_stream
- #endif
- case_orecord:
- switch (Record_type(obj)) {
- case_Rectype_bvector_above;
- case_Rectype_b2vector_above;
- case_Rectype_b4vector_above;
- case_Rectype_b8vector_above;
- case_Rectype_b16vector_above;
- case_Rectype_b32vector_above;
- case_Rectype_string_above;
- case_Rectype_vector_above;
- case_Rectype_mdarray_above;
- case_Rectype_Closure_above;
- case_Rectype_Instance_above;
- #ifndef TYPECODES
- case_Rectype_Symbol_above;
- case Rectype_Ratio:
- case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat:
- case Rectype_Bignum:
- goto case_real;
- case Rectype_Complex: {
- var uint32 code1 = hashcode4_real(TheComplex(obj)->c_real);
- var uint32 code2 = hashcode4_real(TheComplex(obj)->c_imag);
- /* important for combining, because of "complex canonicalization":
- if imagpart=0.0, then hashcode = hashcode4_real(realpart). */
- return code1 ^ rotate_left(5,code2);
- }
- #endif
- default: ;
- }
- /* FIXME: The case that obj is a hash-table should be handled specially. */
- { /* look at flags, type, components: */
- var uintC len = SXrecord_nonweak_length(obj);
- var uint32 bish_code =
- 0x03168B8D + (Record_flags(obj) << 24) + (Record_type(obj) << 16) + len;
- if (len > 0) {
- check_SP();
- var const gcv_object_t* ptr = &TheRecord(obj)->recdata[0];
- var uintC count;
- dotimespC(count,len, {
- var uint32 next_code = hashcode4(*ptr++); /* next component's hashcode */
- bish_code = misch(bish_code,next_code); /* add */
- });
- }
- if (Record_type(obj) >= rectype_limit) {
- var uintC xlen = Xrecord_xlength(obj);
- if (xlen > 0) {
- var const uintB* ptr = (uintB*)&TheRecord(obj)->recdata[len];
- dotimespC(xlen,xlen, {
- var uint32 next_code = *ptr++; /* next byte */
- bish_code = misch(bish_code,next_code); /* add */
- });
- }
- }
- return bish_code;
- }
- case_char: /* character */
- return hashcode4_char(char_code(obj));
- #ifdef TYPECODES
- case_machine: /* machine */
- case_subr: /* subr */
- case_system: /* frame-pointer, small-read-label, system */
- #else
- case_symbol: /* symbol */
- #endif
- case_closure: /* closure */
- case_instance: /* instance */
- case_lrecord:
- /* take EQ-hashcode */
- return hashcode1(obj);
- default: NOTREACHED;
- }
- }
- global uint32 hashcode4 (object obj)
- { return hashcode_tree(obj,hashcode4_atom); }
- /* Tests whether hashcode4 of an object is guaranteed to be GC-invariant. */
- global bool gcinvariant_hashcode4_p (object obj);
- local bool gcinvariant_hashcode4_atom_p (object obj) {
- if (numberp(obj) || gcinvariant_object_p(obj))
- return true;
- #ifdef TYPECODES
- var tint type = typecode(obj) /* typeinfo */
- & ~bit(notsimple_bit_t); /* if simple or not, is irrelevant */
- if (type >= (sbvector_type & ~bit(notsimple_bit_t)) /* bit/byte-vector ? */
- && type <= (sb32vector_type & ~bit(notsimple_bit_t)))
- return true;
- if (type == (sstring_type & ~bit(notsimple_bit_t))) /* string ? */
- return true;
- /* Ignore other types of arrays and records, for simplicity. */
- #else
- if (orecordp(obj))
- switch (Record_type(obj)) {
- case Rectype_Sbvector: case Rectype_bvector:
- case Rectype_Sb2vector: case Rectype_b2vector:
- case Rectype_Sb4vector: case Rectype_b4vector:
- case Rectype_Sb8vector: case Rectype_b8vector:
- case Rectype_Sb16vector: case Rectype_b16vector:
- case Rectype_Sb32vector: case Rectype_b32vector:
- case Rectype_S8string: case Rectype_Imm_S8string:
- case Rectype_S16string: case Rectype_Imm_S16string:
- case Rectype_S32string: case Rectype_Imm_S32string:
- case Rectype_reallocstring: case Rectype_string:
- return true;
- /* Ignore other types of arrays and records, for simplicity. */
- default:
- break;
- }
- #endif
- return false;
- }
- global bool gcinvariant_hashcode4_p (object obj)
- { return gcinvariant_hashcode_tree_p(obj,gcinvariant_hashcode4_atom_p); }
- /* ----------------------------- USER DEFINED ----------------------------- */
- /* hashcode for user-defined ht_test */
- local uint32 hashcode_raw_user (object fun, object obj) {
- pushSTACK(obj); funcall(fun,1);
- value1 = check_uint32(value1);
- return I_to_UL(value1);
- }
- /* =========================== Hash table record =========================== */
- /* Specification of the flags in a hash-table: */
- #define htflags_test_builtin_B (bit(1)|bit(0)) /* for distinguishing builtin tests */
- #define htflags_test_eq_B ( 0 | 0 ) /* test is EQ */
- #define htflags_test_eql_B ( 0 |bit(0)) /* test is EQL */
- #define htflags_test_equal_B (bit(1)| 0 ) /* test is EQUAL */
- #define htflags_test_equalp_B (bit(1)|bit(0)) /* test is EQUALP */
- #define htflags_test_user_B bit(2) /* set for user-defined test */
- /* hash code of instances of STANDARD-STABLEHASH, STRUCTURE-STABLEHASH
- is GC-invariant */
- #define htflags_stablehash_B bit(3)
- /* Must call warn_forced_gc_rehash at the next opportunity */
- #define htflags_pending_warn_forced_gc_rehash bit(4)
- /* Warn when a key is being added whose hash code is not GC-invariant.
- - define htflags_warn_gc_rehash_B bit(5)
- Set after a key has been added whose hash code is not GC-invariant.
- - define htflags_gc_rehash_B bit(6)
- Set when the list structure is invalid and the table needs a rehash.
- - define htflags_invalid_B bit(7)
- Specification of the two types of Pseudo-Functions:
- Specification for LOOKUP - Pseudo-Function:
- lookup(ht,obj,allowgc,&KVptr,&Iptr)
- > ht: hash-table
- > obj: object
- > allowgc: whether GC is allowed during hash lookup
- < if found: result=true,
- KVptr[0], KVptr[1] : key, value in key-value-vector,
- KVptr[2] : index of next entry,
- *Iptr : previous index pointing to KVptr[0..2]
- < if not found: result=false,
- *Iptr : entry belonging to key in index-vector
- or an arbitrary element of the "list" starting there
- can trigger GC - if allowgc is true */
- typedef maygc bool (* lookup_Pseudofun) (object ht, object obj, bool allowgc, gcv_object_t** KVptr_, gcv_object_t** Iptr_);
- /* Specification for HASHCODE - Pseudo-Function:
- hashcode(obj)
- > obj: object
- < result: its hash code */
- typedef uint32 (* hashcode_Pseudofun) (object obj);
- /* Specification for TEST - Pseudo-Function:
- test(obj1,obj2)
- > obj1: object
- > obj2: object
- < result: true if they are considered equal */
- typedef bool (* test_Pseudofun) (object obj1, …
Large files files are truncated, but you can click here to view the full file