Skip to content

Commit 26c895a

Browse files
deyaaeldeendeyaaeldeen
committed
fix a bug in type hashconsing
1 parent 76bd8b5 commit 26c895a

File tree

6 files changed

+42
-65
lines changed

6 files changed

+42
-65
lines changed

‎src/backend-c/generate-c.rkt‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -652,6 +652,8 @@
652652
(display ")")]
653653
[('Types-gen-index! (list))
654654
(display "types_unique_index_counter++")]
655+
[('get-types-hashcons-index (list))
656+
(display "types_unique_index_counter")]
655657
[('mref-cast-queue-enqueue (list addr ty))
656658
(display "cast_queue_enqueue(mref_cast_q,")
657659
(emit-value addr)

‎src/backend-c/runtime/hashcons.c‎

Lines changed: 22 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -17,26 +17,31 @@ table alloc_hash_table(int64_t slots, float load_factor)
1717
return ht;
1818
}
1919

20+
void ht_resize(table ht) {
21+
int64_t old_slots = ht->slots;
22+
chain* old_array = ht->array;
23+
int64_t new_slots = old_slots * 2;
24+
ht->slots = new_slots;
25+
ht->array = GC_MALLOC(8 * new_slots);
26+
int i;
27+
for (i = 0; i < old_slots; ++i) {
28+
chain C = old_array[i];
29+
if (C != NULL) {
30+
list p = C->list;
31+
while (p != NULL) {
32+
types_reinsert(ht, p->data);
33+
p = p->next;
34+
}
35+
}
36+
}
37+
if (old_array) GC_FREE(old_array);
38+
}
39+
2040
int64_t hashcons(table ht, int64_t e, int64_t hcode)
2141
{
2242
float current_load = (float) ht->num_elems/(float) ht->slots;
2343
if (current_load > ht->load_factor) {
24-
int64_t old_slots = ht->slots;
25-
chain* old_array = ht->array;
26-
int64_t new_slots = old_slots * 2;
27-
ht->slots = new_slots;
28-
ht->array = GC_MALLOC(8 * new_slots);
29-
int i;
30-
for (i = 0; i < old_slots; ++i) {
31-
chain C = old_array[i];
32-
if (C != NULL) {
33-
list p = C->list;
34-
while (p != NULL) {
35-
types_reinsert(ht, p->data);
36-
p = p->next;
37-
}
38-
}
39-
}
44+
ht_resize(ht);
4045
}
4146
int h = hcode % ht->slots;
4247
h = h < 0 ? h + ht->slots : h;
@@ -123,7 +128,7 @@ void types_reinsert(table ht, int64_t ty)
123128
switch (tag) {
124129
case TYPE_FN_TAG ... TYPE_MU_TAG:
125130
// the hash index is the same for all types
126-
h = ((int64_t*)untagged_ty)[TYPE_FN_HASH_INDEX] % ht->slots;
131+
h = ((int64_t*)untagged_ty)[TYPE_HASHCONS_HASHCODE_INDEX] % ht->slots;
127132
h = h < 0 ? h + ht->slots : h;
128133
chain C = ht->array[h];
129134
if (C == NULL) {

‎src/backend-c/runtime/hashcons.h‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -27,5 +27,6 @@ table alloc_hash_table(int64_t slots, float load_factor);
2727
int64_t hashcons(table ht, int64_t e, int64_t hcode);
2828
int types_equal(int64_t t1, int64_t t2);
2929
void types_reinsert(table ht, int64_t ty);
30+
void ht_resize(table ht);
3031

3132
#endif

‎src/casts/constants-and-codes.rkt‎

Lines changed: 13 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,8 @@
4444
(TYPE-FLOAT-RT-VALUE #b100111)
4545
(TYPE-CHAR-RT-VALUE #b101111)
4646
(TYPE-MAX-ATOMIC-RT-VALUE #b111111)
47+
(TYPE-HASHCONS-INDEX-INDEX 0)
48+
(TYPE-HASHCONS-HASHCODE-INDEX 1)
4749

4850
(HC-PRJ-TAG-MASK #b10)
4951
(HC-INJ-TAG-MASK #b01)
@@ -393,52 +395,20 @@
393395
[(op$ <= ty TYPE-MAX-ATOMIC-RT-VALUE) ty]
394396
[else
395397
(begin$
396-
(assign$ hcode (calculate-type-hashcode ty))
398+
(assign$ hcode (calculate-type-hashcode ty))
397399
(assign$ hty (op$ Types-hashcons! ty hcode))
398-
(cond$
399-
[(op$ = ty hty)
400-
(begin$
401-
(assign$ index (op$ Types-gen-index!))
402-
(assign$ tag (sr-get-tag ty TYPE-TAG-MASK))
403-
(case$ tag
404-
[(data:TYPE-GREF-TAG)
400+
;; Assumtion: All structural types have two fields in the front,
401+
;; one for the index in the hashconsing table and one for the
402+
;; hashcode.
403+
(when$ (op$ = ty hty)
404+
(assign$ index (op$ get-types-hashcons-index))
405+
(assign$ _unused (op$ Types-gen-index!))
406+
(assign$ tag (sr-get-tag ty TYPE-TAG-MASK))
405407
(sr-tagged-array-set!
406-
hty TYPE-GREF-TAG TYPE-GREF-INDEX-INDEX index)
408+
hty tag TYPE-HASHCONS-INDEX-INDEX index)
407409
(sr-tagged-array-set!
408-
hty TYPE-GREF-TAG TYPE-GREF-HASH-INDEX hcode)]
409-
[(data:TYPE-GVECT-TAG)
410-
(sr-tagged-array-set!
411-
hty TYPE-GVECT-TAG TYPE-GVECT-INDEX-INDEX index)
412-
(sr-tagged-array-set!
413-
hty TYPE-GVECT-TAG TYPE-GVECT-HASH-INDEX hcode)]
414-
[(data:TYPE-MREF-TAG)
415-
(sr-tagged-array-set!
416-
hty TYPE-MREF-TAG TYPE-MREF-INDEX-INDEX index)
417-
(sr-tagged-array-set!
418-
hty TYPE-MREF-TAG TYPE-MREF-HASH-INDEX hcode)]
419-
[(data:TYPE-MVECT-TAG)
420-
(sr-tagged-array-set!
421-
hty TYPE-MVECT-TAG TYPE-MVECT-INDEX-INDEX index)
422-
(sr-tagged-array-set!
423-
hty TYPE-MVECT-TAG TYPE-MVECT-HASH-INDEX hcode)]
424-
[(data:TYPE-TUPLE-TAG)
425-
(sr-tagged-array-set!
426-
hty TYPE-TUPLE-TAG TYPE-TUPLE-INDEX-INDEX index)
427-
(sr-tagged-array-set!
428-
hty TYPE-TUPLE-TAG TYPE-TUPLE-HASH-INDEX hcode)]
429-
[(data:TYPE-FN-TAG)
430-
(sr-tagged-array-set!
431-
hty TYPE-FN-TAG TYPE-FN-INDEX-INDEX index)
432-
(sr-tagged-array-set!
433-
hty TYPE-FN-TAG TYPE-FN-HASH-INDEX hcode)]
434-
[(data:TYPE-MU-TAG)
435-
(sr-tagged-array-set!
436-
hty TYPE-MU-TAG TYPE-MU-INDEX-INDEX index)
437-
(sr-tagged-array-set!
438-
hty TYPE-MU-TAG TYPE-MU-HASH-INDEX hcode)]
439-
[else (op$ Print err-msg) (op$ Exit (Quote 1)) UNDEF-IMDT])
440-
hty)]
441-
[else hty]))])))
410+
hty tag TYPE-HASHCONS-HASHCODE-INDEX hcode))
411+
hty)])))
442412
(add-new-code! (cons hashcons-type runtime-code))
443413
(set-box! hashcons-type-code-label? hashcons-type-code-label)
444414
(App-Code hashcons-type-code-label (list ty))]))

‎src/casts/interpret-casts-common.rkt‎

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -618,8 +618,7 @@ TODO write unit tests
618618
(let$ ([len (Mvector-length address)])
619619
(repeat$ (i ZERO-EXPR len) ()
620620
(let*$ ([vi (Mvector-val-ref address i 'no-check-bounds)]
621-
[cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)]
622-
[t4 (Mvector-rtti-ref address)])
621+
[cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)])
623622
(Mvector-val-set! address i cvi 'no-check-bounds)))
624623
(Mvector-rtti-set! address t3))))))
625624
(define (interp-mvect-state-reduction)
@@ -1957,8 +1956,7 @@ TODO write unit tests
19571956
(let$ ([len (Mvector-length address)])
19581957
(repeat$ (i ZERO-EXPR len) ()
19591958
(let*$ ([vi (Mvector-val-ref address i 'no-check-bounds)]
1960-
[cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)]
1961-
[t4 (Mvector-rtti-ref address)])
1959+
[cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)])
19621960
(Mvector-val-set! address i cvi 'no-check-bounds)))
19631961
(Mvector-rtti-set! address t3)
19641962
(mvect-state-reduction)))))

‎src/language/primitives.rkt‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -136,7 +136,8 @@
136136
(Array-set! #t ((Array Obj) Int Obj -> Unit))
137137
(Array-ref #f ((Array Obj) Int -> Obj))
138138
(Types-hashcons! #t (Type -> Type))
139-
(Types-gen-index! #t (Type -> Unit))
139+
(Types-gen-index! #t (-> Unit))
140+
(get-types-hashcons-index #f (-> Int))
140141
(Printf #t (String (List Obj) -> Unit))
141142
(Print #t (String -> Unit))
142143
(Exit #t (Int -> Bottom)))

0 commit comments

Comments
 (0)