Skip to content

Commit dc2a7a6

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

File tree

5 files changed

+20
-49
lines changed

5 files changed

+20
-49
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: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -123,7 +123,7 @@ void types_reinsert(table ht, int64_t ty)
123123
switch (tag) {
124124
case TYPE_FN_TAG ... TYPE_MU_TAG:
125125
// the hash index is the same for all types
126-
h = ((int64_t*)untagged_ty)[TYPE_FN_HASH_INDEX] % ht->slots;
126+
h = ((int64_t*)untagged_ty)[TYPE_HASHCONS_HASHCODE_INDEX] % ht->slots;
127127
h = h < 0 ? h + ht->slots : h;
128128
chain C = ht->array[h];
129129
if (C == NULL) {

‎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)