common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Use fake %MAKE-LISP-OBJ to implement +-MODFX for host

Browse source 
Gets rid of still more #+/-host in xset
This commit is contained in:
Douglas Katzman 2024-03-09 13:26:09 -05:00
parent 7c45a3f07e
commit 503d086c13
4 changed files with 50 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
src/code/cross-sxhash.lisp
View file

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

4
src/code/string-hash.lisp
View file

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

38
src/code/xset.lisp
View file

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

43
tests/xset.pure.lisp
View file

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