From 2ca94cc3c32e089278c92b3f175dd4411a8aba6e Mon Sep 17 00:00:00 2001 From: Drew Crampsie Date: Sun, 15 Dec 2024 13:44:47 -0800 Subject: [PATCH] Remove GC hash tables for JS --- src/gerbil/runtime/hash.ss | 152 +++++++++++++++++++----------------- src/gerbil/runtime/table.ss | 110 ++++++++++++-------------- 2 files changed, 131 insertions(+), 131 deletions(-) diff --git a/src/gerbil/runtime/hash.ss b/src/gerbil/runtime/hash.ss index 0a2272f9e..2aa791ee2 100644 --- a/src/gerbil/runtime/hash.ss +++ b/src/gerbil/runtime/hash.ss @@ -51,14 +51,16 @@ namespace: #f (bind-method! __table::t 'copy raw-table-copy) (bind-method! __table::t 'clear! raw-table-clear!) -(bind-method! __gc-table::t 'ref gc-table-ref) -(bind-method! __gc-table::t 'set! gc-table-set!) -(bind-method! __gc-table::t 'update! gc-table-update!) -(bind-method! __gc-table::t 'delete! gc-table-delete!) -(bind-method! __gc-table::t 'for-each gc-table-for-each) -(bind-method! __gc-table::t 'length gc-table-length) -(bind-method! __gc-table::t 'copy gc-table-copy) -(bind-method! __gc-table::t 'clear! gc-table-clear!) +(cond-expand + (,(compilation-target? c) + (bind-method! __gc-table::t 'ref gc-table-ref) + (bind-method! __gc-table::t 'set! gc-table-set!) + (bind-method! __gc-table::t 'update! gc-table-update!) + (bind-method! __gc-table::t 'delete! gc-table-delete!) + (bind-method! __gc-table::t 'for-each gc-table-for-each) + (bind-method! __gc-table::t 'length gc-table-length) + (bind-method! __gc-table::t 'copy gc-table-copy) + (bind-method! __gc-table::t 'clear! gc-table-clear!))) (def (gambit-table-update! table key update default) (let (result (table-ref table key default)) @@ -122,48 +124,50 @@ namespace: #f #f ; class-type-constructor #f)))) -;; immediate gc-hash-table class; reifies the gc-table type -(def gc-hash-table::t - (begin-annotation - (@mop.class gerbil#gc-hash-table::t ; type-id - (object::t) ; super - (gcht immediate) ; slots - #f ; constructor - #t ; struct? - #f ; final? - #f) ; metaclass - (let* ((slots '(gcht immediate)) - (slot-vector - (list->vector (cons #f slots))) - (slot-table - (let (slot-table (make-symbolic-table #f 0)) - (for-each - (lambda (slot field) - (symbolic-table-set! slot-table slot field) - (symbolic-table-set! slot-table (symbol->keyword slot) field)) - slots - (iota (length slots) 1)) - slot-table)) - (flags - (##fxior type-flag-extensible type-flag-concrete type-flag-id - class-type-flag-struct)) - (fields '#()) - (properties - `((direct-slots: ,@slots) - (struct: . #t)))) - (##structure - class::t ; type - 'gerbil#gc-hash-table::t ; type-id - 'hash-table ; type-name - flags ; type-flags - __gc-table::t ; type-super - fields ; type-fields - [object::t t::t] ; class-type-precedence-list - slot-vector ; class-type-slot-vector - slot-table ; class-type-slot-table - properties ; class-type-properties - #f ; class-type-constructor - #f)))) +(cond-expand + (,(compilation-target? C) + ;; immediate gc-hash-table class; reifies the gc-table type + (def gc-hash-table::t + (begin-annotation + (@mop.class gerbil#gc-hash-table::t ; type-id + (object::t) ; super + (gcht immediate) ; slots + #f ; constructor + #t ; struct? + #f ; final? + #f) ; metaclass + (let* ((slots '(gcht immediate)) + (slot-vector + (list->vector (cons #f slots))) + (slot-table + (let (slot-table (make-symbolic-table #f 0)) + (for-each + (lambda (slot field) + (symbolic-table-set! slot-table slot field) + (symbolic-table-set! slot-table (symbol->keyword slot) field)) + slots + (iota (length slots) 1)) + slot-table)) + (flags + (##fxior type-flag-extensible type-flag-concrete type-flag-id + class-type-flag-struct)) + (fields '#()) + (properties + `((direct-slots: ,@slots) + (struct: . #t)))) + (##structure + class::t ; type + 'gerbil#gc-hash-table::t ; type-id + 'hash-table ; type-name + flags ; type-flags + __gc-table::t ; type-super + fields ; type-fields + [object::t t::t] ; class-type-precedence-list + slot-vector ; class-type-slot-vector + slot-table ; class-type-slot-table + properties ; class-type-properties + #f ; class-type-constructor + #f)))))) ;; locked hash table; wraps a HashTable instance to lock on primitive operations (defstruct locked-hash-table (table lock) @@ -229,14 +233,16 @@ namespace: #f (bind-method! immediate-hash-table::t 'update! immediate-table-update!) (bind-method! immediate-hash-table::t 'delete! immediate-table-delete!) -(bind-method! gc-hash-table::t 'ref gc-table-ref) -(bind-method! gc-hash-table::t 'set! gc-table-set!) -(bind-method! gc-hash-table::t 'update! gc-table-update!) -(bind-method! gc-hash-table::t 'delete! gc-table-delete!) -(bind-method! gc-hash-table::t 'for-each gc-table-for-each) -(bind-method! gc-hash-table::t 'length gc-table-length) -(bind-method! gc-hash-table::t 'copy gc-table-copy) -(bind-method! gc-hash-table::t 'clear! gc-table-clear!) +(cond-expand + (,(compilation-target? C) + (bind-method! gc-hash-table::t 'ref gc-table-ref) + (bind-method! gc-hash-table::t 'set! gc-table-set!) + (bind-method! gc-hash-table::t 'update! gc-table-update!) + (bind-method! gc-hash-table::t 'delete! gc-table-delete!) + (bind-method! gc-hash-table::t 'for-each gc-table-for-each) + (bind-method! gc-hash-table::t 'length gc-table-length) + (bind-method! gc-hash-table::t 'copy gc-table-copy) + (bind-method! gc-hash-table::t 'clear! gc-table-clear!))) ;; HashTable interface methods (def hash-table? @@ -394,14 +400,16 @@ namespace: #f (wrap-lock ht) key?))) - (def (make-gc-hash-table) - => HashTable - (let (ht - (HashTable - (make-gc-table size-hint gc-hash-table::t))) - (wrap-checked - (wrap-lock ht) - true))) + (cond-expand + (,(compilation-target? C) + (def (make-gc-hash-table) + => HashTable + (let (ht + (HashTable + (make-gc-table size-hint gc-hash-table::t))) + (wrap-checked + (wrap-lock ht) + true))))) (def (make-gambit-table) => HashTable @@ -430,10 +438,14 @@ namespace: #f (cond ((or weak-keys weak-values) (make-gambit-table)) - ((and (or (eq? test eq?) (eq? test ##eq?)) - (or (not hash) (eq? hash eq?-hash) (eq? hash eq-hash)) - (not seed)) - (make-gc-hash-table)) + ((and + (or (eq? test eq?) (eq? test ##eq?)) + (or (not hash) (eq? hash eq?-hash) (eq? hash eq-hash)) + (not seed)) + (cond-expand (,(compilation-target? C) + (make-gc-hash-table)) + (else + (make make-eq-hash-table true eq-hash eq?)))) ((and (or (eq? test eq?) (eq? test ##eq?)) (or (not hash) (eq? hash eq?-hash) (eq? hash eq-hash))) (make make-eq-hash-table true eq-hash eq?)) diff --git a/src/gerbil/runtime/table.ss b/src/gerbil/runtime/table.ss index 733270202..8c587bda1 100644 --- a/src/gerbil/runtime/table.ss +++ b/src/gerbil/runtime/table.ss @@ -67,7 +67,6 @@ namespace: #f (__table-ref table seed hash test key default))) (def (raw-table-set! tab key value) - ;; (displayln "raw table set" tab " " key " " value) (when (fx< (&raw-table-free tab) (fxquotient (vector-length (&raw-table-table tab)) 4)) (__raw-table-rehash! tab)) @@ -112,15 +111,11 @@ namespace: #f (set! (&raw-table-free tab) (fxquotient (vector-length (&raw-table-table tab)) 2))) -(def ##_raw_table_setting '()) (def (__raw-table-set! tab key value) - ;;(displayln "start __raw table set" tab) (let ((table (&raw-table-table tab)) (seed (&raw-table-seed tab)) (hash (&raw-table-hash tab)) (test (&raw-table-test tab))) - (when (void? hash) - (error "deep in raw table set" tab key value hash test)) (__table-set! table seed hash test key value (lambda () ; insert (set! (&raw-table-free tab) (fx- (&raw-table-free tab) 1)) @@ -233,7 +228,9 @@ namespace: #f (defrules __symbolic-hash () ((_ obj) - (##symbol-hash obj))) + (cond-expand + (,(compilation-target? C) (macro-slot 1 obj)) + (else (##symbol-hash obj))))) (def (string-hash obj) (##string=?-hash obj)) @@ -352,7 +349,6 @@ namespace: #f (size (vector-length table)) (entries (fxquotient size 2)) (start (fxarithmetic-shift-left (fxmodulo h entries) 1))) - ;; (displayln "In the __table-set! rule" key value) (let loop ((probe start) (i 1) (deleted #f)) (let (k (vector-ref table probe)) (cond @@ -421,6 +417,8 @@ namespace: #f (else (loop (probe-step start i size) (fx+ i 1))))))))) +(cond-expand + (,(compilation-target? C) ;;; gc tables -- specialized eq? tables that use gambit's gchts directly ;;; Note: we keep two separate tables, a gcht for memory allocated objects ;; and an immediate-table for immediate objects, as gcht don't seem to work with @@ -458,19 +456,14 @@ namespace: #f (set! (&gc-table-immediate tab) immediate) immediate)))) -(cond-expand - (,(compilation-target? js) - (def (__gc-table-new size flags) - (##make-table size: size test: eq?))) - (else - (def (__gc-table-new size flags) - (let* ((flags - (fxand flags (fxnot (macro-gc-hash-table-flag-need-rehash)))) - (flags - (fxior flags (macro-gc-hash-table-flag-mem-alloc-keys))) - (gcht - (##gc-hash-table-allocate size flags __gc-table-loads))) - gcht)))) +(def (__gc-table-new size flags) + (let* ((flags + (fxand flags (fxnot (macro-gc-hash-table-flag-need-rehash)))) + (flags + (fxior flags (macro-gc-hash-table-flag-mem-alloc-keys))) + (gcht + (##gc-hash-table-allocate size flags __gc-table-loads))) + gcht)) (def (__gc-table-e tab) (declare (not interrupts-enabled)) @@ -491,7 +484,7 @@ namespace: #f (set! (&gc-table-gcht tab) gcht))) (def (gc-table-ref tab key default) - (declare (not interrupts-enabled) (safe)) + (declare (not interrupts-enabled)) (cond ((##mem-allocated? key) (let (gcht (__gc-table-e tab)) @@ -506,23 +499,14 @@ namespace: #f (def (gc-table-set! tab key value) (declare (not interrupts-enabled)) - (cond-expand - (,(compilation-target? js) - (let ((tbl (if (##table? tab) tab (__gc-table-e tab)))) - #;(error "GC-TABLE-SET" tab tbl key value) - (if (##table? tbl) - (##table-set! tbl key value) - (error "Wrong table inside gc table:" tbl)))) - (else - (if (##mem-allocated? key) - (let (gcht (__gc-table-e tab)) - (when (##gc-hash-table-set! gcht key value) - (__gc-table-rehash! tab) - (gc-table-set! tab key value))) - (immediate-table-set! (__gc-table-immediate tab) key value))))) + (if (##mem-allocated? key) + (let (gcht (__gc-table-e tab)) + (when (##gc-hash-table-set! gcht key value) + (__gc-table-rehash! tab) + (gc-table-set! tab key value))) + (immediate-table-set! (__gc-table-immediate tab) key value))) (def (gc-table-update! tab key update default) - (error "undefined") (if (##mem-allocated? key) (let (value (gc-table-ref tab key default)) (gc-table-set! tab key (update value))) @@ -530,7 +514,6 @@ namespace: #f (def (gc-table-delete! tab key) (declare (not interrupts-enabled)) - (error "undefined") (cond ((##mem-allocated? key) (let (gcht (__gc-table-e tab)) @@ -544,8 +527,7 @@ namespace: #f (def (gc-table-for-each tab proc) (declare (not interrupts-enabled)) ;; mem allocated first - (error "undefined") - (let (gcht (__gc-table-e tab)) + (let (gcht (__gc-table-e tab)) (let loop ((i (macro-gc-hash-table-key0))) (when (fx< i (##vector-length gcht)) (let (key (##vector-ref gcht i)) @@ -562,7 +544,6 @@ namespace: #f (raw-table-for-each immediate proc))))) (def (gc-table-copy tab) - (error "undefined") (let* ((gcht (__gc-table-e tab)) (new-table (__gc-table-new @@ -575,7 +556,6 @@ namespace: #f result)) (def (gc-table-clear! tab) - (error "undefined") (let* ((gcht (__gc-table-e tab)) (new-table (__gc-table-new 16 (macro-gc-hash-table-flags gcht)))) @@ -583,32 +563,40 @@ namespace: #f (set! (&gc-table-immediate tab) #f))) (def (gc-table-length tab) - (error "undefined") (let (gcht (__gc-table-e tab)) (fx+ (macro-gc-hash-table-count gcht) (cond ((&gc-table-immediate tab) => &raw-table-count) (else 0))))) +;; +)) + + ;;; object->eq-hash -(def __object-eq-hash-next 0) -(def __object-eq-hash +(cond-expand + (,(compilation-target? C) + (def __object-eq-hash-next 0) + (def __object-eq-hash (make-gc-table 1024 __gc-table::t (macro-gc-hash-table-flag-weak-keys))) -(def (__object->eq-hash obj) - (declare (not interrupts-enabled)) - (let (val (gc-table-ref __object-eq-hash obj #f)) - (if val - val - (let* ((mix __object-eq-hash-next) - (ptr (##type-cast obj 0)) - (h (fxand (fxxor mix ptr) (macro-max-fixnum32)))) - (set! __object-eq-hash-next (or (##fx+? __object-eq-hash-next 1) 0)) - - ((cond-expand - (,(compilation-target? js) ##table-set!) - (else gc-table-set!)) - __object-eq-hash obj h) - - - h)))) + (def (__object->eq-hash obj) + (declare (not interrupts-enabled)) + (let (val (gc-table-ref __object-eq-hash obj #f)) + (if val + val + (let* ((mix __object-eq-hash-next) + (ptr (##type-cast obj 0)) + (h (fxand (fxxor mix ptr) (macro-max-fixnum32)))) + (set! __object-eq-hash-next (or (##fx+? __object-eq-hash-next 1) 0)) + (gc-table-set! __object-eq-hash obj h) + h))))) + (,(compilation-target? js) + (def __object->eq-hash ##eq?-hash))) + + + + + + +