X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-sxhash.lisp;h=cbc226771e99e40e4632dfe870a24a574ccf1f9e;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=5e7b3d9d68aea2c0b1009f7431c2d8ad374c45b1;hpb=8e1eb3714554b8b93455895756787f6c4f63afc5;p=sbcl.git diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp index 5e7b3d9..cbc2267 100644 --- a/src/code/target-sxhash.lisp +++ b/src/code/target-sxhash.lisp @@ -36,9 +36,10 @@ ;;; * We'd like this to be simple and fast, too. ;;; ;;; FIXME: Should this be INLINE? -(declaim (ftype (function ((and fixnum unsigned-byte) - (and fixnum unsigned-byte)) - (and fixnum unsigned-byte)) mix)) +(declaim (ftype (sfunction ((and fixnum unsigned-byte) + (and fixnum unsigned-byte)) + (and fixnum unsigned-byte)) + mix)) (defun mix (x y) ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler ;; were smarter about optimizing ASH. (Without the THE FIXNUM below, @@ -63,33 +64,45 @@ ;; algorithms, but we're not pushing them hard enough here for them ;; to be cryptographically strong.) (let* ((xy (+ (* x 3) y))) - (declare (type (unsigned-byte 32) xy)) - (the (and fixnum unsigned-byte) - (logand most-positive-fixnum - (logxor 441516657 - xy - (the fixnum (ash xy -5))))))) + (logand most-positive-fixnum + (logxor 441516657 + xy + (ash xy -5))))) ;;;; hashing strings ;;;; -;;;; Note that this operation is used in compiler symbol table lookups, so we'd -;;;; like it to be fast. +;;;; Note that this operation is used in compiler symbol table +;;;; lookups, so we'd like it to be fast. +;;;; +;;;; As of 2004-03-10, we implement the one-at-a-time algorithm +;;;; designed by Bob Jenkins (see +;;;; for some more +;;;; information). #!-sb-fluid (declaim (inline %sxhash-substring)) (defun %sxhash-substring (string &optional (count (length string))) ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the - ;; cross-compiler were smarter about ASH, but we need it for sbcl-0.5.0m. + ;; cross-compiler were smarter about ASH, but we need it for + ;; sbcl-0.5.0m. (probably no longer true? We might need SAFETY 0 + ;; to elide some type checks, but then again if this is inlined in + ;; all the critical places, we might not -- CSR, 2004-03-10) (declare (optimize (speed 3) (safety 0))) (declare (type string string)) (declare (type index count)) - (let ((result 408967240)) - (declare (type fixnum result)) - (dotimes (i count) - (declare (type index i)) - (mixf result - (the fixnum - (ash (char-code (aref string i)) 5)))) - result)) + (macrolet ((set-result (form) + `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form)))) + (let ((result 0)) + (declare (type (unsigned-byte #.sb!vm:n-word-bits) result)) + (unless (typep string '(vector nil)) + (dotimes (i count) + (declare (type index i)) + (set-result (+ result (char-code (aref string i)))) + (set-result (+ result (ash result 10))) + (set-result (logxor result (ash result -6))))) + (set-result (+ result (ash result 3))) + (set-result (logxor result (ash result -11))) + (set-result (logxor result (ash result 15))) + (logand result most-positive-fixnum)))) ;;; test: ;;; (let ((ht (make-hash-table :test 'equal))) ;;; (do-all-symbols (symbol) @@ -104,17 +117,36 @@ (defun %sxhash-simple-string (x) (declare (optimize speed)) (declare (type simple-string x)) - (%sxhash-substring x)) + ;; KLUDGE: this FLET is a workaround (suggested by APD) for presence + ;; of let conversion in the cross compiler, which otherwise causes + ;; strongly suboptimal register allocation. + (flet ((trick (x) + (%sxhash-substring x))) + (declare (notinline trick)) + (trick x))) (defun %sxhash-simple-substring (x count) (declare (optimize speed)) (declare (type simple-string x)) (declare (type index count)) - (%sxhash-substring x count)) + ;; see comment in %SXHASH-SIMPLE-STRING + (flet ((trick (x count) + (%sxhash-substring x count))) + (declare (notinline trick)) + (trick x count))) ;;;; the SXHASH function +;; simple cases +(declaim (ftype (sfunction (integer) (integer 0 #.sb!xc:most-positive-fixnum)) + sxhash-bignum)) +(declaim (ftype (sfunction (t) (integer 0 #.sb!xc:most-positive-fixnum)) + sxhash-instance)) + (defun sxhash (x) + ;; profiling SXHASH is hard, but we might as well try to make it go + ;; fast, in case it is the bottleneck somwhere. -- CSR, 2003-03-14 + (declare (optimize speed)) (labels ((sxhash-number (x) (etypecase x (fixnum (sxhash x)) ; through DEFTRANSFORM @@ -132,30 +164,43 @@ (mixf result (sxhash-number (realpart x))) (mixf result (sxhash-number (imagpart x))) result)))) - (sxhash-recurse (x &optional (depthoid +max-hash-depthoid+)) + (sxhash-recurse (x depthoid) (declare (type index depthoid)) (typecase x + ;; we test for LIST here, rather than CONS, because the + ;; type test for CONS is in fact the test for + ;; LIST-POINTER-LOWTAG followed by a negated test for + ;; NIL. If we're going to have to test for NIL anyway, + ;; we might as well do it explicitly and pick off the + ;; answer. -- CSR, 2004-07-14 (list - (if (plusp depthoid) - (mix (sxhash-recurse (car x) (1- depthoid)) - (sxhash-recurse (cdr x) (1- depthoid))) - 261835505)) + (if (null x) + (sxhash x) ; through DEFTRANSFORM + (if (plusp depthoid) + (mix (sxhash-recurse (car x) (1- depthoid)) + (sxhash-recurse (cdr x) (1- depthoid))) + 261835505))) (instance - (if (typep x 'structure-object) + (if (or (typep x 'structure-object) (typep x 'condition)) (logxor 422371266 (sxhash ; through DEFTRANSFORM - (class-name (layout-class (%instance-layout x))))) + (classoid-name + (layout-classoid (%instance-layout x))))) (sxhash-instance x))) (symbol (sxhash x)) ; through DEFTRANSFORM (array (typecase x (simple-string (sxhash x)) ; through DEFTRANSFORM (string (%sxhash-substring x)) - (bit-vector (let ((result 410823708)) - (declare (type fixnum result)) - (dotimes (i (min depthoid (length x))) - (mixf result (aref x i))) - result)) + (simple-bit-vector (sxhash x)) ; through DEFTRANSFORM + (bit-vector + ;; FIXME: It must surely be possible to do better + ;; than this. The problem is that a non-SIMPLE + ;; BIT-VECTOR could be displaced to another, with a + ;; non-zero offset -- so that significantly more + ;; work needs to be done using the %RAW-BITS + ;; approach. This will probably do for now. + (sxhash-recurse (copy-seq x) depthoid)) (t (logxor 191020317 (sxhash (array-rank x)))))) (character (logxor 72185131 @@ -164,7 +209,7 @@ (number (sxhash-number x)) (generic-function (sxhash-instance x)) (t 42)))) - (sxhash-recurse x))) + (sxhash-recurse x +max-hash-depthoid+))) ;;;; the PSXHASH function @@ -187,7 +232,7 @@ (array (array-psxhash key depthoid)) (hash-table (hash-table-psxhash key)) (structure-object (structure-object-psxhash key depthoid)) - (list (list-psxhash key depthoid)) + (cons (list-psxhash key depthoid)) (number (number-psxhash key)) (character (sxhash (char-upcase key))) (t (sxhash key)))) @@ -240,17 +285,20 @@ (declare (type (integer 0 #.+max-hash-depthoid+) depthoid)) (let* ((layout (%instance-layout key)) ; i.e. slot #0 (length (layout-length layout)) - (class (layout-class layout)) - (name (class-name class)) + (classoid (layout-classoid layout)) + (name (classoid-name classoid)) (result (mix (sxhash name) (the fixnum 79867)))) (declare (type fixnum result)) - (dotimes (i (min depthoid (1- length))) + (dotimes (i (min depthoid (- length 1 (layout-n-untagged-slots layout)))) (declare (type fixnum i)) (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT (declare (type fixnum j)) (mixf result (psxhash (%instance-ref key j) (1- depthoid))))) + ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+ + ;; is pretty low currently, so they might not make it into the hash + ;; value anyway.) result)) (defun list-psxhash (key depthoid) @@ -306,7 +354,7 @@ (etypecase key (single-float (frob single-float)) (double-float (frob double-float)) - (short-float (frob short-float)) + #!+long-float (long-float (error "LONG-FLOAT not currently supported"))))) (rational (if (and (<= most-negative-double-float key