summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-11-20 14:07:03 +0100
committerAndy Wingo <wingo@pobox.com>2023-11-20 14:23:14 +0100
commit5959531c54d1a164e638731b8d79633f454a3dbd (patch)
tree884bb4ee76bacfd0b03a324f1009ad130b0e2d19 /module/language
parent4d834bdc12acef0f7353da8a22ef0480f818bdb8 (diff)
downloadguile-5959531c54d1a164e638731b8d79633f454a3dbd.tar.gz
Allow target runtime to override symbol hash
Also rework so that the symbol hash uses the low bits instead of high bits. We can do this because, for the guile-vm target, now we compute the full target hash. * module/language/cps/guile-vm.scm (jenkins-lookup3-hashword2): (target-symbol-hash, target-symbol-hash-bits): New exported functions.. * module/language/cps/switch.scm (optimize-branch-chain): Change to use target-symbol-hash and target-symbol-hash-bits from the current target-runtime.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/guile-vm.scm71
-rw-r--r--module/language/cps/switch.scm63
2 files changed, 99 insertions, 35 deletions
diff --git a/module/language/cps/guile-vm.scm b/module/language/cps/guile-vm.scm
index f330128f2..772783349 100644
--- a/module/language/cps/guile-vm.scm
+++ b/module/language/cps/guile-vm.scm
@@ -27,8 +27,77 @@
#:use-module (language cps guile-vm loop-instrumentation)
#:use-module (language cps guile-vm lower-primcalls)
#:use-module (language cps guile-vm reify-primitives)
+ #:use-module (system base target)
#:export (make-lowerer
- available-optimizations))
+ available-optimizations
+ target-symbol-hash
+ target-symbol-hash-bits))
+
+;; This hash function is originally from
+;; http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
+;; Public Domain. No warranty.
+(define (jenkins-lookup3-hashword2 str)
+ (define (u32 x) (logand x #xffffFFFF))
+ (define (shl x n) (u32 (ash x n)))
+ (define (shr x n) (ash x (- n)))
+ (define (rot x n) (logior (shl x n) (shr x (- 32 n))))
+ (define (add x y) (u32 (+ x y)))
+ (define (sub x y) (u32 (- x y)))
+ (define (xor x y) (logxor x y))
+
+ (define (mix a b c)
+ (let* ((a (sub a c)) (a (xor a (rot c 4))) (c (add c b))
+ (b (sub b a)) (b (xor b (rot a 6))) (a (add a c))
+ (c (sub c b)) (c (xor c (rot b 8))) (b (add b a))
+ (a (sub a c)) (a (xor a (rot c 16))) (c (add c b))
+ (b (sub b a)) (b (xor b (rot a 19))) (a (add a c))
+ (c (sub c b)) (c (xor c (rot b 4))) (b (add b a)))
+ (values a b c)))
+ (define (final a b c)
+ (let* ((c (xor c b)) (c (sub c (rot b 14)))
+ (a (xor a c)) (a (sub a (rot c 11)))
+ (b (xor b a)) (b (sub b (rot a 25)))
+ (c (xor c b)) (c (sub c (rot b 16)))
+ (a (xor a c)) (a (sub a (rot c 4)))
+ (b (xor b a)) (b (sub b (rot a 14)))
+ (c (xor c b)) (c (sub c (rot b 24))))
+ (values a b c)))
+
+ (define len (string-length str))
+ (define (add-char x index)
+ (add x (char->integer (string-ref str index))))
+
+ (let ((init (add #xdeadbeef (add (shl len 2) 47))))
+ (let lp ((i 0) (a init) (b init) (c init))
+ (let ((remaining (- len i)))
+ (cond
+ ((< 3 remaining)
+ (call-with-values (lambda ()
+ (mix (add-char a i)
+ (add-char b (+ i 1))
+ (add-char c (+ i 2))))
+ (lambda (a b c)
+ (lp (+ i 3) a b c))))
+ (else
+ (let* ((a (if (<= 1 remaining) (add-char a i) a))
+ (b (if (<= 2 remaining) (add-char b (+ i 1)) b))
+ (c (if (<= 3 remaining) (add-char c (+ i 2)) c)))
+ (final a b c))))))))
+
+(define (target-symbol-hash str)
+ (call-with-values (lambda () (jenkins-lookup3-hashword2 str))
+ (lambda (a b c)
+ ;; The high 32 bits of the hash on a 64-bit platform are
+ ;; equivalent to the hash on a 32-bit platform. The top two bits
+ ;; are zero to allow the hash to fit in a fixnum.
+ (ash (case (target-word-size)
+ ((4) c)
+ ((8) (logior (ash c 32) b))
+ (else (error "unexpected target word size" (target-word-size))))
+ -2))))
+
+(define target-symbol-hash-bits
+ (- (* (target-word-size) 8) 2))
(define (make-lowerer optimization-level opts)
(lambda (exp env)
diff --git a/module/language/cps/switch.scm b/module/language/cps/switch.scm
index f4ae40567..84c5d0f77 100644
--- a/module/language/cps/switch.scm
+++ b/module/language/cps/switch.scm
@@ -148,8 +148,8 @@ object."
(hash-table->alist specials)
(hash-table->sorted-alist symbols
(lambda (s1 s2)
- (< (symbol-hash s1)
- (symbol-hash s2))))
+ (string< (symbol->string s1)
+ (symbol->string s2))))
(hash-table->alist others))))
;; Leave any chain this long or less as is.
@@ -320,44 +320,39 @@ object."
((null? targets)
(with-cps cps next))
((length>? targets *symbol-hash-dispatch-min-length*)
- ;; Hash dispatch. Targets already sorted by symbol-hash. The
- ;; symbol-hash accessor returns the hash of a symbol, which is the
- ;; hash of its associated stringbuf. The high 32 bits of the hash
- ;; on a 64-bit platform are equivalent to the hash on a 32-bit
- ;; platform. The top two bits are zero, to ensure that hash
- ;; values can be represented as fixnums. We therefore dispatch on
- ;; the top N bits, skipping 2 bits, where N <= 30, for the
- ;; smallest N for which len(targets) <= 2^N.
- (let* ((nbits (let ((ntargets (length targets)))
+ ;; Hash dispatch. The value has symbol-hash-bits significant
+ ;; bits. We dispatch on the bottom N bits of the significant
+ ;; bits, where N <= symbol-hash-bits, for the smallest N for which
+ ;; len(targets) <= 2^N.
+ (let* ((backend (resolve-interface `(language cps ,(target-runtime))))
+ (symbol-hash (module-ref backend 'target-symbol-hash))
+ (symbol-hash-bits (module-ref backend 'target-symbol-hash-bits))
+ (nbits (let ((ntargets (length targets)))
(let lp ((nbits 2))
- (if (<= ntargets (ash 1 nbits))
- nbits
- (lp (1+ nbits))))))
- (host-shift (- (* (with-native-target target-word-size) 8) 2 nbits))
- (target-shift (- (* (target-word-size) 8) 2 nbits))
+ (cond
+ ((= nbits symbol-hash-bits) nbits)
+ ((<= ntargets (ash 1 nbits)) nbits)
+ (else (lp (1+ nbits)))))))
(nbuckets (ash 1 nbits))
(buckets (make-vector nbuckets '()))
(kt* (make-vector nbuckets exit)))
- (define (next-targets targets next-bucket)
- (let lp ((out '()) (targets targets))
- (match targets
- (() (values out targets))
- (((sym . k) . targets*)
- (if (< (symbol-hash sym) next-bucket)
- (lp (acons sym k out) targets*)
- (values out targets))))))
- (let lp ((cps cps) (i 0) (targets targets))
+ (define (symbol->bucket sym)
+ (logand (1- nbuckets) (symbol-hash (symbol->string sym))))
+ (define (vector-push! v i x)
+ (vector-set! v i (cons x (vector-ref v i))))
+ (for-each (match-lambda
+ ((and pair (sym . target))
+ (vector-push! buckets (symbol->bucket sym) pair)))
+ targets)
+ (let lp ((cps cps) (i 0))
(cond
((< i nbuckets)
(call-with-values (lambda ()
- (next-targets targets (ash (1+ i) host-shift)))
- (lambda (bucket targets)
- (call-with-values
- (lambda ()
- (reify-chain cps var bucket 'eq-constant? exit))
- (lambda (cps k)
- (vector-set! kt* i k)
- (lp cps (1+ i) targets))))))
+ (reify-chain cps var (vector-ref buckets i)
+ 'eq-constant? exit))
+ (lambda (cps k)
+ (vector-set! kt* i k)
+ (lp cps (1+ i)))))
(else
(with-cps cps
(letv hash idx)
@@ -367,7 +362,7 @@ object."
(letk kidx
($kargs ('hash) (hash)
($continue kswitch #f
- ($primcall 'ursh/immediate target-shift (hash)))))
+ ($primcall 'ulogand/immediate (1- nbuckets) (hash)))))
(letk khash
($kargs () ()
($continue kidx #f