From 503d086c13c601257c476bbfa12e4957a2f1f8b3 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sat, 9 Mar 2024 13:26:09 -0500 Subject: [PATCH] Use fake %MAKE-LISP-OBJ to implement +-MODFX for host Gets rid of still more #+/-host in xset --- src/code/cross-sxhash.lisp | 34 ++++++++++++++++++++++++++++++ src/code/string-hash.lisp | 4 +--- src/code/xset.lisp | 38 ++++----------------------------- tests/xset.pure.lisp | 43 ++++++++++---------------------------- 4 files changed, 50 insertions(+), 69 deletions(-) diff --git a/src/code/cross-sxhash.lisp b/src/code/cross-sxhash.lisp index 7114caebd..868d199d5 100644 --- a/src/code/cross-sxhash.lisp +++ b/src/code/cross-sxhash.lisp @@ -165,3 +165,37 @@ (t ; use the algorithm of https://xkcd.com/221/ ;; This case is hit maybe a few dozen times in cross-compiling. (values 4 t)))) + +(defun %make-lisp-obj (bits) ; Cast BITS (a representation) to fixnum + (declare (type sb-vm:word bits)) + (flet ((sign-extend (int size) ; borrowed from disassem.lisp + (if (logbitp (1- size) int) + (dpb int (byte size 0) -1) + int))) + (if (= (logand bits sb-vm:fixnum-tag-mask) 0) + (sign-extend (ash bits (- sb-vm:n-fixnum-tag-bits)) sb-vm:n-fixnum-bits) + (bug "%MAKE-LISP-OBJ can only make fixnums")))) + +;;; Every architecture needs this portable replacement for +-modfx. +;;; Some, but not all, define +-modfx in cross-modular. +;;; We need this available sooner than that because type-classes needs it +;;; to compute a hash of a list of things order-insensitively. +(defun plus-mod-fixnum (a b) + (declare (type sb-xc:fixnum a b)) + (labels ((representation (x) (mask-to-word (ash x sb-vm:n-fixnum-tag-bits))) + (mask-to-word (x) (ldb (byte sb-vm:n-word-bits 0) x))) + (%make-lisp-obj (mask-to-word (+ (representation a) (representation b)))))) + +;; Assume 2 fixnum tag bits: +;; significant bits tag +;; #b01111...11111111111111 00 +;; + #b0 1 00 +;; ------------------------ +;; = #b10000...00000000000000 00 +(assert (= (plus-mod-fixnum sb-xc:most-positive-fixnum 1) + sb-xc:most-negative-fixnum)) +;; etc +(assert (= (plus-mod-fixnum sb-xc:most-negative-fixnum sb-xc:most-negative-fixnum) + 0)) +(assert (= (plus-mod-fixnum -1 most-negative-fixnum) + sb-xc:most-positive-fixnum)) diff --git a/src/code/string-hash.lisp b/src/code/string-hash.lisp index 6cd848be4..cb000ae1b 100644 --- a/src/code/string-hash.lisp +++ b/src/code/string-hash.lisp @@ -168,12 +168,10 @@ ;;; This hash function on sb-vm:word returns a fixnum, does not cons, ;;; and has better avalanche behavior then SXHASH - changing any one input bit ;;; should affect each bit of output with equal chance. -#-sb-xc-host -(progn (declaim (inline murmur-hash-word/fixnum)) ; don't want to cons the word to pass in (defun murmur-hash-word/fixnum (x) ; result may be positive or negative (%make-lisp-obj (logandc2 (murmur3-fmix-word (truly-the sb-vm:word x)) - sb-vm:fixnum-tag-mask)))) + sb-vm:fixnum-tag-mask))) ;;; Similar, but the sign bit is always 0 (declaim (inline murmur-hash-word/+fixnum)) (defun murmur-hash-word/+fixnum (x) diff --git a/src/code/xset.lisp b/src/code/xset.lisp index 29b75522d..ba1d80b30 100644 --- a/src/code/xset.lisp +++ b/src/code/xset.lisp @@ -195,36 +195,8 @@ xset) t) -#-sb-xc-host (defmacro plus-mod-fixnum (a b) `(sb-vm::+-modfx ,a ,b)) - -;;; Every architecture needs this portable replacement for +-modfx. -;;; Some, but not all, define +-modfx in cross-modular. -;;; We need this available sooner than that because type-classes needs it -;;; to compute a hash of a list of things order-insensitively. -#+sb-xc-host -(progn -(defun plus-mod-fixnum (a b) - (declare (type sb-xc:fixnum a b)) - (let* ((mask (ldb (byte sb-vm:n-fixnum-bits 0) -1)) - (result (logand (+ (logand a mask) (logand b mask)) mask))) - (if (logbitp sb-vm:n-positive-fixnum-bits result) ; then it's negative - (dpb result (byte sb-vm:n-fixnum-bits 0) -1) - result))) - -;; Assume 2 fixnum tag bits: -;; significant bits tag -;; #b01111...11111111111111 00 -;; + #b0 1 00 -;; ------------------------ -;; = #b10000...00000000000000 00 -(assert (= (plus-mod-fixnum sb-xc:most-positive-fixnum 1) - sb-xc:most-negative-fixnum)) -;; etc -(assert (= (plus-mod-fixnum sb-xc:most-negative-fixnum sb-xc:most-negative-fixnum) - 0)) -(assert (= (plus-mod-fixnum -1 most-negative-fixnum) - sb-xc:most-positive-fixnum)) -) +(defmacro plus-mod-fixnum (a b) + `(#+sb-xc-host sb-c::plus-mod-fixnum #-sb-xc-host sb-vm::+-modfx ,a ,b)) ;;; Produce a hash that helps decide whether two xsets could be considered equivalent ;;; as order-insensitive sets comparing elements by EQL. @@ -272,11 +244,9 @@ (dx-flet ((assign-hash (x) (multiple-value-bind (h address-based) (sb-impl::eql-hash x) (setf (aref hashes (incf index)) - ;; EQL-HASH does not hash fixnums well. Hash-tables - ;; use PREFUZZ-HASH, so this should do something similar. (acond ((not address-based) - (#+sb-xc-host progn - #-sb-xc-host murmur-hash-word/fixnum h)) + ;; EQL-HASH does not hash fixnums well enough + (murmur-hash-word/fixnum h)) ((gethash x hashmap) (incf (car it)) ; bump refcount it) diff --git a/tests/xset.pure.lisp b/tests/xset.pure.lisp index 8199b036b..0a0213c90 100644 --- a/tests/xset.pure.lisp +++ b/tests/xset.pure.lisp @@ -54,35 +54,14 @@ (assert (sb-int:xset= union1 union2)))))) (with-test (:name :xset-dedup-list-to-hash) - (compile nil - '(lambda (p1) - (declare (type - (or - (or - (and - (or symbol t) - (or - (and - (or - (or symbol (member p standard-char-p f -)) - (vector *)) - (or - (and (or (member structure-class - #:g15490820) list) - (or list (member #:g15490821 - atan))) - (or - (member #:g15490817 #("a") char-name #:g15490818 - #:g15490819) - (or array - (member interactive-stream-p #:g15490816 - multiple-value-bind nil u))))) - (and (or (cons (array * (9)) t) list) - (or - (eql - (53391669 -44590101 - (#\b "081uw~" -52809.280758190354d0))) - (array * 1))))) - (or (member d y :b byte-position i echo-stream-output-stream) - (member z w #:g15490815 nil g q t))) - (or character (member #\1 -50073916617313))) - p1)) - p1))) + (let ((x (sb-int:alloc-xset))) + (dotimes (i 20) + (sb-int:add-to-xset i x)) + (assert (listp (sb-kernel::xset-data x))) + (dotimes (i 20) + (sb-int:add-to-xset i x)) + ;; didn't upgrade to a hash-table + (assert (listp (sb-kernel::xset-data x))) + (sb-kernel::xset-generate-stable-hashes x) + ;; doesn't affect representation of DATA slot + (assert (listp (sb-kernel::xset-data x)))))