src/code/target-sxhash.lisp

   1 ;;;; hashing functions
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (defun pointer-hash (key)
  15   (pointer-hash key))
  16
  17 ;;; the depthoid explored when calculating hash values
  18 ;;;
  19 ;;; "Depthoid" here is a sort of mixture of what Common Lisp ordinarily calls
  20 ;;; depth and what Common Lisp ordinarily calls length; it's incremented either
  21 ;;; when we descend into a compound object or when we step through elements of
  22 ;;; a compound object.
  23 (defconstant +max-hash-depthoid+ 4)
  24 \f
  25 ;;;; mixing hash values
  26
  27 ;;; a function for mixing hash values
  28 ;;;
  29 ;;; desiderata:
  30 ;;;   * Non-commutativity keeps us from hashing e.g. #(1 5) to the
  31 ;;;     same value as #(5 1), and ending up in real trouble in some
  32 ;;;     special cases like bit vectors the way that CMUCL 18b SXHASH
  33 ;;;     does. (Under CMUCL 18b, SXHASH of any bit vector is 1..)
  34 ;;;   * We'd like to scatter our hash values over the entire possible range
  35 ;;;     of values instead of hashing small or common key values (like
  36 ;;;     2 and NIL and #\a) to small FIXNUMs the way that the CMUCL 18b
  37 ;;;     SXHASH function does, again helping to avoid pathologies like
  38 ;;;     hashing all bit vectors to 1.
  39 ;;;   * We'd like this to be simple and fast, too.
  40 (declaim (ftype (sfunction ((and fixnum unsigned-byte)
  41                             (and fixnum unsigned-byte))
  42                            (and fixnum unsigned-byte))
  43                 mix))
  44 (declaim (inline mix))
  45 (defun mix (x y)
  46   (declare (optimize (speed 3)))
  47   (declare (type (and fixnum unsigned-byte) x y))
  48   ;; the ideas here:
  49   ;;   * Bits diffuse in both directions (shifted arbitrarily left by
  50   ;;     the multiplication in the calculation of XY, and shifted
  51   ;;     right by up to 5 places by the ASH).
  52   ;;   * The #'+ and #'LOGXOR operations don't commute with each other,
  53   ;;     so different bit patterns are mixed together as they shift
  54   ;;     past each other.
  55   ;;   * The arbitrary constant XOR used in the LOGXOR expression is
  56   ;;     intended to help break up any weird anomalies we might
  57   ;;     otherwise get when hashing highly regular patterns.
  58   ;; (These are vaguely like the ideas used in many cryptographic
  59   ;; algorithms, but we're not pushing them hard enough here for them
  60   ;; to be cryptographically strong.)
  61   ;;
  62   ;; note: 3622009729038463111 is a 62-bit prime such that its low 61
  63   ;; bits, low 60 bits and low 29 bits are all also primes, thus
  64   ;; giving decent distributions no matter which of the possible
  65   ;; values of most-positive-fixnum we have.  It is derived by simple
  66   ;; search starting from 2^60*pi.  The multiplication should be
  67   ;; efficient no matter what the platform thanks to modular
  68   ;; arithmetic.
  69   (let* ((mul (logand 3622009729038463111 sb!xc:most-positive-fixnum))
  70          (xor (logand 608948948376289905 sb!xc:most-positive-fixnum))
  71          (xy (logand (+ (* x mul) y) sb!xc:most-positive-fixnum)))
  72     (logand (logxor xor xy (ash xy -5)) sb!xc:most-positive-fixnum)))
  73 \f
  74 ;;;; hashing strings
  75 ;;;;
  76 ;;;; Note that this operation is used in compiler symbol table
  77 ;;;; lookups, so we'd like it to be fast.
  78 ;;;;
  79 ;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
  80 ;;;; designed by Bob Jenkins (see
  81 ;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
  82 ;;;; information).
  83
  84 (declaim (inline %sxhash-substring))
  85 (defun %sxhash-substring (string &optional (count (length string)))
  86   ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
  87   ;; cross-compiler were smarter about ASH, but we need it for
  88   ;; sbcl-0.5.0m.  (probably no longer true?  We might need SAFETY 0
  89   ;; to elide some type checks, but then again if this is inlined in
  90   ;; all the critical places, we might not -- CSR, 2004-03-10)
  91   (declare (optimize (speed 3) (safety 0)))
  92   (declare (type string string))
  93   (declare (type index count))
  94   (macrolet ((set-result (form)
  95                `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form))))
  96     (let ((result 0))
  97       (declare (type (unsigned-byte #.sb!vm:n-word-bits) result))
  98       (unless (typep string '(vector nil))
  99         (dotimes (i count)
 100           (declare (type index i))
 101           (set-result (+ result (char-code (aref string i))))
 102           (set-result (+ result (ash result 10)))
 103           (set-result (logxor result (ash result -6)))))
 104       (set-result (+ result (ash result 3)))
 105       (set-result (logxor result (ash result -11)))
 106       (set-result (logxor result (ash result 15)))
 107       (logand result most-positive-fixnum))))
 108 ;;; test:
 109 ;;;   (let ((ht (make-hash-table :test 'equal)))
 110 ;;;     (do-all-symbols (symbol)
 111 ;;;       (let* ((string (symbol-name symbol))
 112 ;;;           (hash (%sxhash-substring string)))
 113 ;;;      (if (gethash hash ht)
 114 ;;;          (unless (string= (gethash hash ht) string)
 115 ;;;            (format t "collision: ~S ~S~%" string (gethash hash ht)))
 116 ;;;          (setf (gethash hash ht) string))))
 117 ;;;     (format t "final count=~W~%" (hash-table-count ht)))
 118
 119 (defun %sxhash-simple-string (x)
 120   (declare (optimize speed))
 121   (declare (type simple-string x))
 122   ;; KLUDGE: this FLET is a workaround (suggested by APD) for presence
 123   ;; of let conversion in the cross compiler, which otherwise causes
 124   ;; strongly suboptimal register allocation.
 125   (flet ((trick (x)
 126            (%sxhash-substring x)))
 127     (declare (notinline trick))
 128     (trick x)))
 129
 130 (defun %sxhash-simple-substring (x count)
 131   (declare (optimize speed))
 132   (declare (type simple-string x))
 133   (declare (type index count))
 134   ;; see comment in %SXHASH-SIMPLE-STRING
 135   (flet ((trick (x count)
 136            (%sxhash-substring x count)))
 137     (declare (notinline trick))
 138     (trick x count)))
 139 \f
 140 ;;;; the SXHASH function
 141
 142 ;; simple cases
 143 (declaim (ftype (sfunction (integer) hash) sxhash-bignum))
 144 (declaim (ftype (sfunction (t) hash) sxhash-instance))
 145
 146 (defun sxhash (x)
 147   ;; profiling SXHASH is hard, but we might as well try to make it go
 148   ;; fast, in case it is the bottleneck somewhere.  -- CSR, 2003-03-14
 149   (declare (optimize speed))
 150   (labels ((sxhash-number (x)
 151              (etypecase x
 152                (fixnum (sxhash x))      ; through DEFTRANSFORM
 153                (integer (sb!bignum:sxhash-bignum x))
 154                (single-float (sxhash x)) ; through DEFTRANSFORM
 155                (double-float (sxhash x)) ; through DEFTRANSFORM
 156                #!+long-float (long-float (error "stub: no LONG-FLOAT"))
 157                (ratio (let ((result 127810327))
 158                         (declare (type fixnum result))
 159                         (mixf result (sxhash-number (numerator x)))
 160                         (mixf result (sxhash-number (denominator x)))
 161                         result))
 162                (complex (let ((result 535698211))
 163                           (declare (type fixnum result))
 164                           (mixf result (sxhash-number (realpart x)))
 165                           (mixf result (sxhash-number (imagpart x)))
 166                           result))))
 167            (sxhash-recurse (x depthoid)
 168              (declare (type index depthoid))
 169              (typecase x
 170                ;; we test for LIST here, rather than CONS, because the
 171                ;; type test for CONS is in fact the test for
 172                ;; LIST-POINTER-LOWTAG followed by a negated test for
 173                ;; NIL.  If we're going to have to test for NIL anyway,
 174                ;; we might as well do it explicitly and pick off the
 175                ;; answer.  -- CSR, 2004-07-14
 176                (list
 177                 (if (null x)
 178                     (sxhash x) ; through DEFTRANSFORM
 179                     (if (plusp depthoid)
 180                         (mix (sxhash-recurse (car x) (1- depthoid))
 181                              (sxhash-recurse (cdr x) (1- depthoid)))
 182                         261835505)))
 183                (instance
 184                 (if (pathnamep x)
 185                     ;; Pathnames are EQUAL if all the components are EQUAL, so
 186                     ;; we hash all of the components of a pathname together.
 187                     (let ((hash (sxhash-recurse (pathname-host x) depthoid)))
 188                       (mixf hash (sxhash-recurse (pathname-device x) depthoid))
 189                       (mixf hash (sxhash-recurse (pathname-directory x) depthoid))
 190                       (mixf hash (sxhash-recurse (pathname-name x) depthoid))
 191                       (mixf hash (sxhash-recurse (pathname-type x) depthoid))
 192                       ;; Hash :NEWEST the same as NIL because EQUAL for
 193                       ;; pathnames assumes that :newest and nil are equal.
 194                       (let ((version (%pathname-version x)))
 195                         (mixf hash (sxhash-recurse (if (eq version :newest)
 196                                                        nil
 197                                                        version)
 198                                                    depthoid))))
 199                     (if (or (typep x 'structure-object) (typep x 'condition))
 200                         (logxor 422371266
 201                                 (sxhash ; through DEFTRANSFORM
 202                                  (classoid-name
 203                                   (layout-classoid (%instance-layout x)))))
 204                         (sxhash-instance x))))
 205                (symbol (sxhash x)) ; through DEFTRANSFORM
 206                (array
 207                 (typecase x
 208                   (simple-string (sxhash x)) ; through DEFTRANSFORM
 209                   (string (%sxhash-substring x))
 210                   (simple-bit-vector (sxhash x)) ; through DEFTRANSFORM
 211                   (bit-vector
 212                    ;; FIXME: It must surely be possible to do better
 213                    ;; than this.  The problem is that a non-SIMPLE
 214                    ;; BIT-VECTOR could be displaced to another, with a
 215                    ;; non-zero offset -- so that significantly more
 216                    ;; work needs to be done using the %VECTOR-RAW-BITS
 217                    ;; approach.  This will probably do for now.
 218                    (sxhash-recurse (copy-seq x) depthoid))
 219                   (t (logxor 191020317 (sxhash (array-rank x))))))
 220                (character
 221                 (logxor 72185131
 222                         (sxhash (char-code x)))) ; through DEFTRANSFORM
 223                ;; general, inefficient case of NUMBER
 224                (number (sxhash-number x))
 225                (generic-function (sxhash-instance x))
 226                (t 42))))
 227     (sxhash-recurse x +max-hash-depthoid+)))
 228 \f
 229 ;;;; the PSXHASH function
 230
 231 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
 232 ;;;; more efficient (in both time and space) by rewriting it along the lines
 233 ;;;; of the SXHASH code above.
 234
 235 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
 236 (defun psxhash (key &optional (depthoid +max-hash-depthoid+))
 237   (declare (optimize speed))
 238   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 239   ;; Note: You might think it would be cleaner to use the ordering given in the
 240   ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
 241   ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
 242   ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
 243   ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
 244   ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
 245   ;; comparison behavior.
 246   (typecase key
 247     (array (array-psxhash key depthoid))
 248     (hash-table (hash-table-psxhash key))
 249     (structure-object (structure-object-psxhash key depthoid))
 250     (cons (list-psxhash key depthoid))
 251     (number (number-psxhash key))
 252     (character (char-code (char-upcase key)))
 253     (t (sxhash key))))
 254
 255 (defun array-psxhash (key depthoid)
 256   (declare (optimize speed))
 257   (declare (type array key))
 258   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 259   (typecase key
 260     ;; VECTORs have to be treated specially because ANSI specifies
 261     ;; that we must respect fill pointers.
 262     (vector
 263      (macrolet ((frob ()
 264                   '(let ((result 572539))
 265                      (declare (type fixnum result))
 266                      (mixf result (length key))
 267                     (when (plusp depthoid)
 268                       (decf depthoid)
 269                       (dotimes (i (length key))
 270                        (declare (type fixnum i))
 271                        (mixf result
 272                              (psxhash (aref key i) depthoid))))
 273                     result))
 274                 (make-dispatch (types)
 275                   `(typecase key
 276                      ,@(loop for type in types
 277                              collect `(,type
 278                                        (frob))))))
 279        (make-dispatch (simple-base-string
 280                        (simple-array character (*))
 281                        simple-vector
 282                        (simple-array (unsigned-byte 8) (*))
 283                        (simple-array fixnum (*))
 284                        t))))
 285     ;; Any other array can be hashed by working with its underlying
 286     ;; one-dimensional physical representation.
 287     (t
 288      (let ((result 60828))
 289        (declare (type fixnum result))
 290        (dotimes (i (array-rank key))
 291          (mixf result (array-dimension key i)))
 292        (when (plusp depthoid)
 293          (decf depthoid)
 294          (dotimes (i (array-total-size key))
 295           (mixf result
 296                 (psxhash (row-major-aref key i) depthoid))))
 297        result))))
 298
 299 (defun structure-object-psxhash (key depthoid)
 300   (declare (optimize speed))
 301   (declare (type structure-object key))
 302   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 303   (let* ((layout (%instance-layout key)) ; i.e. slot #0
 304          (length (layout-length layout))
 305          (classoid (layout-classoid layout))
 306          (name (classoid-name classoid))
 307          (result (mix (sxhash name) (the fixnum 79867))))
 308     (declare (type fixnum result))
 309     (dotimes (i (min depthoid (- length 1 (layout-n-untagged-slots layout))))
 310       (declare (type fixnum i))
 311       (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT
 312         (declare (type fixnum j))
 313         (mixf result
 314               (psxhash (%instance-ref key j)
 315                        (1- depthoid)))))
 316     ;; KLUDGE: Should hash untagged slots, too.  (Although +max-hash-depthoid+
 317     ;; is pretty low currently, so they might not make it into the hash
 318     ;; value anyway.)
 319     result))
 320
 321 (defun list-psxhash (key depthoid)
 322   (declare (optimize speed))
 323   (declare (type list key))
 324   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 325   (cond ((null key)
 326          (the fixnum 480929))
 327         ((zerop depthoid)
 328          (the fixnum 779578))
 329         (t
 330          (mix (psxhash (car key) (1- depthoid))
 331               (psxhash (cdr key) (1- depthoid))))))
 332
 333 (defun hash-table-psxhash (key)
 334   (declare (optimize speed))
 335   (declare (type hash-table key))
 336   (let ((result 103924836))
 337     (declare (type fixnum result))
 338     (mixf result (hash-table-count key))
 339     (mixf result (sxhash (hash-table-test key)))
 340     result))
 341
 342 (defun number-psxhash (key)
 343   (declare (optimize speed))
 344   (declare (type number key))
 345   (flet ((sxhash-double-float (val)
 346            (declare (type double-float val))
 347            ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
 348            ;; resulting code works without consing. (In Debian cmucl 2.4.17,
 349            ;; it didn't.)
 350            (sxhash val)))
 351     (etypecase key
 352       (integer (sxhash key))
 353       (float (macrolet ((frob (type)
 354                           (let ((lo (coerce sb!xc:most-negative-fixnum type))
 355                                 (hi (coerce sb!xc:most-positive-fixnum type)))
 356                             `(cond (;; This clause allows FIXNUM-sized integer
 357                                     ;; values to be handled without consing.
 358                                     (<= ,lo key ,hi)
 359                                     (multiple-value-bind (q r)
 360                                         (floor (the (,type ,lo ,hi) key))
 361                                       (if (zerop (the ,type r))
 362                                           (sxhash q)
 363                                           (sxhash-double-float
 364                                            (coerce key 'double-float)))))
 365                                    (t
 366                                     (multiple-value-bind (q r) (floor key)
 367                                       (if (zerop (the ,type r))
 368                                           (sxhash q)
 369                                           (sxhash-double-float
 370                                            (coerce key 'double-float)))))))))
 371                (etypecase key
 372                  (single-float (frob single-float))
 373                  (double-float (frob double-float))
 374                  #!+long-float
 375                  (long-float (error "LONG-FLOAT not currently supported")))))
 376       (rational (if (and (<= most-negative-double-float
 377                              key
 378                              most-positive-double-float)
 379                          (= (coerce key 'double-float) key))
 380                     (sxhash-double-float (coerce key 'double-float))
 381                     (sxhash key)))
 382       (complex (if (zerop (imagpart key))
 383                    (number-psxhash (realpart key))
 384                    (let ((result 330231))
 385                      (declare (type fixnum result))
 386                      (mixf result (number-psxhash (realpart key)))
 387                      (mixf result (number-psxhash (imagpart key)))
 388                      result))))))