From 8410c66601f20b556ad2364393773ba4243deaf1 Mon Sep 17 00:00:00 2001 From: Deyaaeldeen Almahallawi Date: Wed, 8 Apr 2020 12:03:46 -0400 Subject: [PATCH 1/2] fix a bug in type hashconsing --- src/backend-c/generate-c.rkt | 2 + src/backend-c/runtime/hashcons.c | 40 +++++++++++--------- src/backend-c/runtime/hashcons.h | 1 + src/casts/constants-and-codes.rkt | 56 +++++++--------------------- src/casts/interpret-casts-common.rkt | 6 +-- src/language/primitives.rkt | 3 +- 6 files changed, 42 insertions(+), 66 deletions(-) diff --git a/src/backend-c/generate-c.rkt b/src/backend-c/generate-c.rkt index b7f3d908..0326a623 100644 --- a/src/backend-c/generate-c.rkt +++ b/src/backend-c/generate-c.rkt @@ -652,6 +652,8 @@ (display ")")] [('Types-gen-index! (list)) (display "types_unique_index_counter++")] + [('get-types-hashcons-index (list)) + (display "types_unique_index_counter")] [('mref-cast-queue-enqueue (list addr ty)) (display "cast_queue_enqueue(mref_cast_q,") (emit-value addr) diff --git a/src/backend-c/runtime/hashcons.c b/src/backend-c/runtime/hashcons.c index 7d887ddc..c050808e 100644 --- a/src/backend-c/runtime/hashcons.c +++ b/src/backend-c/runtime/hashcons.c @@ -17,26 +17,31 @@ table alloc_hash_table(int64_t slots, float load_factor) return ht; } +void ht_resize(table ht) { + int64_t old_slots = ht->slots; + chain* old_array = ht->array; + int64_t new_slots = old_slots * 2; + ht->slots = new_slots; + ht->array = GC_MALLOC(8 * new_slots); + int i; + for (i = 0; i < old_slots; ++i) { + chain C = old_array[i]; + if (C != NULL) { + list p = C->list; + while (p != NULL) { + types_reinsert(ht, p->data); + p = p->next; + } + } + } + if (old_array) GC_FREE(old_array); +} + int64_t hashcons(table ht, int64_t e, int64_t hcode) { float current_load = (float) ht->num_elems/(float) ht->slots; if (current_load > ht->load_factor) { - int64_t old_slots = ht->slots; - chain* old_array = ht->array; - int64_t new_slots = old_slots * 2; - ht->slots = new_slots; - ht->array = GC_MALLOC(8 * new_slots); - int i; - for (i = 0; i < old_slots; ++i) { - chain C = old_array[i]; - if (C != NULL) { - list p = C->list; - while (p != NULL) { - types_reinsert(ht, p->data); - p = p->next; - } - } - } + ht_resize(ht); } int h = hcode % ht->slots; h = h < 0 ? h + ht->slots : h; @@ -122,8 +127,7 @@ void types_reinsert(table ht, int64_t ty) int64_t h; switch (tag) { case TYPE_FN_TAG ... TYPE_MU_TAG: - // the hash index is the same for all types - h = ((int64_t*)untagged_ty)[TYPE_FN_HASH_INDEX] % ht->slots; + h = ((int64_t*)untagged_ty)[TYPE_HASHCONS_HASHCODE_INDEX] % ht->slots; h = h < 0 ? h + ht->slots : h; chain C = ht->array[h]; if (C == NULL) { diff --git a/src/backend-c/runtime/hashcons.h b/src/backend-c/runtime/hashcons.h index 763b46be..6cada330 100644 --- a/src/backend-c/runtime/hashcons.h +++ b/src/backend-c/runtime/hashcons.h @@ -27,5 +27,6 @@ table alloc_hash_table(int64_t slots, float load_factor); int64_t hashcons(table ht, int64_t e, int64_t hcode); int types_equal(int64_t t1, int64_t t2); void types_reinsert(table ht, int64_t ty); +void ht_resize(table ht); #endif diff --git a/src/casts/constants-and-codes.rkt b/src/casts/constants-and-codes.rkt index ac193788..5dd7e088 100644 --- a/src/casts/constants-and-codes.rkt +++ b/src/casts/constants-and-codes.rkt @@ -44,6 +44,8 @@ (TYPE-FLOAT-RT-VALUE #b100111) (TYPE-CHAR-RT-VALUE #b101111) (TYPE-MAX-ATOMIC-RT-VALUE #b111111) + (TYPE-HASHCONS-INDEX-INDEX 0) + (TYPE-HASHCONS-HASHCODE-INDEX 1) (HC-PRJ-TAG-MASK #b10) (HC-INJ-TAG-MASK #b01) @@ -393,52 +395,20 @@ [(op$ <= ty TYPE-MAX-ATOMIC-RT-VALUE) ty] [else (begin$ - (assign$ hcode (calculate-type-hashcode ty)) + (assign$ hcode (calculate-type-hashcode ty)) (assign$ hty (op$ Types-hashcons! ty hcode)) - (cond$ - [(op$ = ty hty) - (begin$ - (assign$ index (op$ Types-gen-index!)) - (assign$ tag (sr-get-tag ty TYPE-TAG-MASK)) - (case$ tag - [(data:TYPE-GREF-TAG) + ;; Assumtion: All structural types have two fields in the front, + ;; one for the index in the hashconsing table and one for the + ;; hashcode. + (when$ (op$ = ty hty) + (assign$ index (op$ get-types-hashcons-index)) + (assign$ _unused (op$ Types-gen-index!)) + (assign$ tag (sr-get-tag ty TYPE-TAG-MASK)) (sr-tagged-array-set! - hty TYPE-GREF-TAG TYPE-GREF-INDEX-INDEX index) + hty tag TYPE-HASHCONS-INDEX-INDEX index) (sr-tagged-array-set! - hty TYPE-GREF-TAG TYPE-GREF-HASH-INDEX hcode)] - [(data:TYPE-GVECT-TAG) - (sr-tagged-array-set! - hty TYPE-GVECT-TAG TYPE-GVECT-INDEX-INDEX index) - (sr-tagged-array-set! - hty TYPE-GVECT-TAG TYPE-GVECT-HASH-INDEX hcode)] - [(data:TYPE-MREF-TAG) - (sr-tagged-array-set! - hty TYPE-MREF-TAG TYPE-MREF-INDEX-INDEX index) - (sr-tagged-array-set! - hty TYPE-MREF-TAG TYPE-MREF-HASH-INDEX hcode)] - [(data:TYPE-MVECT-TAG) - (sr-tagged-array-set! - hty TYPE-MVECT-TAG TYPE-MVECT-INDEX-INDEX index) - (sr-tagged-array-set! - hty TYPE-MVECT-TAG TYPE-MVECT-HASH-INDEX hcode)] - [(data:TYPE-TUPLE-TAG) - (sr-tagged-array-set! - hty TYPE-TUPLE-TAG TYPE-TUPLE-INDEX-INDEX index) - (sr-tagged-array-set! - hty TYPE-TUPLE-TAG TYPE-TUPLE-HASH-INDEX hcode)] - [(data:TYPE-FN-TAG) - (sr-tagged-array-set! - hty TYPE-FN-TAG TYPE-FN-INDEX-INDEX index) - (sr-tagged-array-set! - hty TYPE-FN-TAG TYPE-FN-HASH-INDEX hcode)] - [(data:TYPE-MU-TAG) - (sr-tagged-array-set! - hty TYPE-MU-TAG TYPE-MU-INDEX-INDEX index) - (sr-tagged-array-set! - hty TYPE-MU-TAG TYPE-MU-HASH-INDEX hcode)] - [else (op$ Print err-msg) (op$ Exit (Quote 1)) UNDEF-IMDT]) - hty)] - [else hty]))]))) + hty tag TYPE-HASHCONS-HASHCODE-INDEX hcode)) + hty)]))) (add-new-code! (cons hashcons-type runtime-code)) (set-box! hashcons-type-code-label? hashcons-type-code-label) (App-Code hashcons-type-code-label (list ty))])) diff --git a/src/casts/interpret-casts-common.rkt b/src/casts/interpret-casts-common.rkt index 1bcb89f1..5cd2a44b 100644 --- a/src/casts/interpret-casts-common.rkt +++ b/src/casts/interpret-casts-common.rkt @@ -618,8 +618,7 @@ TODO write unit tests (let$ ([len (Mvector-length address)]) (repeat$ (i ZERO-EXPR len) () (let*$ ([vi (Mvector-val-ref address i 'no-check-bounds)] - [cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)] - [t4 (Mvector-rtti-ref address)]) + [cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)]) (Mvector-val-set! address i cvi 'no-check-bounds))) (Mvector-rtti-set! address t3)))))) (define (interp-mvect-state-reduction) @@ -1957,8 +1956,7 @@ TODO write unit tests (let$ ([len (Mvector-length address)]) (repeat$ (i ZERO-EXPR len) () (let*$ ([vi (Mvector-val-ref address i 'no-check-bounds)] - [cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)] - [t4 (Mvector-rtti-ref address)]) + [cvi (interp-cast vi t1 t3 monotonic-blame suspend-monotonic-heap-casts)]) (Mvector-val-set! address i cvi 'no-check-bounds))) (Mvector-rtti-set! address t3) (mvect-state-reduction))))) diff --git a/src/language/primitives.rkt b/src/language/primitives.rkt index b768f7f5..e6358a7a 100644 --- a/src/language/primitives.rkt +++ b/src/language/primitives.rkt @@ -136,7 +136,8 @@ (Array-set! #t ((Array Obj) Int Obj -> Unit)) (Array-ref #f ((Array Obj) Int -> Obj)) (Types-hashcons! #t (Type -> Type)) - (Types-gen-index! #t (Type -> Unit)) + (Types-gen-index! #t (-> Unit)) + (get-types-hashcons-index #f (-> Int)) (Printf #t (String (List Obj) -> Unit)) (Print #t (String -> Unit)) (Exit #t (Int -> Bottom))) From e131cd07e35552132b7e99a02acc0aa1b19d0409 Mon Sep 17 00:00:00 2001 From: Deyaaeldeen Almahallawi Date: Wed, 8 Apr 2020 12:25:34 -0400 Subject: [PATCH 2/2] removing the index field from types --- src/backend-c/generate-c.rkt | 9 ++------- src/backend-c/runtime/runtime.h | 1 - src/casts/constants-and-codes.rkt | 15 +++------------ 3 files changed, 5 insertions(+), 20 deletions(-) diff --git a/src/backend-c/generate-c.rkt b/src/backend-c/generate-c.rkt index 0326a623..17d97960 100644 --- a/src/backend-c/generate-c.rkt +++ b/src/backend-c/generate-c.rkt @@ -163,7 +163,7 @@ (: emit-var-declarations (-> (Listof Uid) Void)) (define (emit-var-declarations d*) (display "\n//These are the variable declarations\n") - (display "\ntable types_ht;\nint64_t types_unique_index_counter;\n") + (display "\ntable types_ht;\n") (display "\ncast_queue* mref_cast_q;\ncast_queue* mvect_cast_q;\n") (display cast-profiler/external-c-decl*) (display-seq (map uid->string d*) "" (string-append IMDT-C-TYPE " ") "" ";\n" "")) @@ -179,8 +179,7 @@ (: initialize-types-table (-> Void)) (define (initialize-types-table) (printf "types_ht = alloc_hash_table(~a, ~a);\n" - (init-types-hash-table-slots) (types-hash-table-load-factor)) - (display "types_unique_index_counter = 0;")) + (init-types-hash-table-slots) (types-hash-table-load-factor))) (: initialize-suspended-cast-queues (-> Void)) (define (initialize-suspended-cast-queues) @@ -650,10 +649,6 @@ (display ",") (emit-value hcode) (display ")")] - [('Types-gen-index! (list)) - (display "types_unique_index_counter++")] - [('get-types-hashcons-index (list)) - (display "types_unique_index_counter")] [('mref-cast-queue-enqueue (list addr ty)) (display "cast_queue_enqueue(mref_cast_q,") (emit-value addr) diff --git a/src/backend-c/runtime/runtime.h b/src/backend-c/runtime/runtime.h index 2227a6b7..8e3eb219 100644 --- a/src/backend-c/runtime/runtime.h +++ b/src/backend-c/runtime/runtime.h @@ -22,7 +22,6 @@ #include "suspended_cast.h" extern table types_ht; -extern int64_t types_unique_index_counter; extern cast_queue* mref_cast_q; extern cast_queue* mvect_cast_q; diff --git a/src/casts/constants-and-codes.rkt b/src/casts/constants-and-codes.rkt index 5dd7e088..4b8e4fd8 100644 --- a/src/casts/constants-and-codes.rkt +++ b/src/casts/constants-and-codes.rkt @@ -44,8 +44,7 @@ (TYPE-FLOAT-RT-VALUE #b100111) (TYPE-CHAR-RT-VALUE #b101111) (TYPE-MAX-ATOMIC-RT-VALUE #b111111) - (TYPE-HASHCONS-INDEX-INDEX 0) - (TYPE-HASHCONS-HASHCODE-INDEX 1) + (TYPE-HASHCONS-HASHCODE-INDEX 0) (HC-PRJ-TAG-MASK #b10) (HC-INJ-TAG-MASK #b01) @@ -229,8 +228,6 @@ (format-id stx "~a-~a?" namespace-string name-string)) (define/with-syntax namespace-mask-def (format-id stx "~a-TAG-MASK" namespace-string-caps)) - (define/with-syntax index-def - (format-id stx "~a-INDEX-INDEX" qualified-upcase-name)) (define/with-syntax hash-def (format-id stx "~a-HASH-INDEX" qualified-upcase-name)) (define/with-syntax tag-def (format-id stx "~a-TAG" qualified-upcase-name)) @@ -259,8 +256,7 @@ [else #`(sr-alloc #,name-string tag-def - `(("index" . ,(Quote 0)) - ("hashcode" . ,(Quote 0)) + `(("hashcode" . ,(Quote 0)) (field* . ,alloc-val*) ...))])))) (define/with-syntax equal-arg (generate-temporary)) (define (gen-func-access*) @@ -309,8 +305,7 @@ #`(begin (define-constants (tag-def tag) - (index-def 0) - (hash-def 1) + (hash-def 0) (sindex/offset-def* sindex/offset-val*) ...) func-alloc (define (func-huh-name equal-arg) @@ -401,11 +396,7 @@ ;; one for the index in the hashconsing table and one for the ;; hashcode. (when$ (op$ = ty hty) - (assign$ index (op$ get-types-hashcons-index)) - (assign$ _unused (op$ Types-gen-index!)) (assign$ tag (sr-get-tag ty TYPE-TAG-MASK)) - (sr-tagged-array-set! - hty tag TYPE-HASHCONS-INDEX-INDEX index) (sr-tagged-array-set! hty tag TYPE-HASHCONS-HASHCODE-INDEX hcode)) hty)])))