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 ;;; the depthoid explored when calculating hash values
  15 ;;;
  16 ;;; "Depthoid" here is a sort of mixture of what Common Lisp ordinarily calls
  17 ;;; depth and what Common Lisp ordinarily calls length; it's incremented either
  18 ;;; when we descend into a compound object or when we step through elements of
  19 ;;; a compound object.
  20 (defconstant +max-hash-depthoid+ 4)
  21 \f
  22 ;;;; mixing hash values
  23
  24 ;;; a function for mixing hash values
  25 ;;;
  26 ;;; desiderata:
  27 ;;;   * Non-commutativity keeps us from hashing e.g. #(1 5) to the
  28 ;;;     same value as #(5 1), and ending up in real trouble in some
  29 ;;;     special cases like bit vectors the way that CMUCL 18b SXHASH
  30 ;;;     does. (Under CMUCL 18b, SXHASH of any bit vector is 1..)
  31 ;;;   * We'd like to scatter our hash values over the entire possible range
  32 ;;;     of values instead of hashing small or common key values (like
  33 ;;;     2 and NIL and #\a) to small FIXNUMs the way that the CMUCL 18b
  34 ;;;     SXHASH function does, again helping to avoid pathologies like
  35 ;;;     hashing all bit vectors to 1.
  36 ;;;   * We'd like this to be simple and fast, too.
  37 ;;;
  38 ;;; FIXME: Should this be INLINE?
  39 (declaim (ftype (function ((and fixnum unsigned-byte)
  40                            (and fixnum unsigned-byte))
  41                           (and fixnum unsigned-byte)) mix))
  42 (defun mix (x y)
  43   ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
  44   ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,
  45   ;; and the (SAFETY 0) declaration here to get the compiler to trust
  46   ;; it, the sbcl-0.5.0m cross-compiler running under Debian
  47   ;; cmucl-2.4.17 turns the ASH into a full call, requiring the
  48   ;; UNSIGNED-BYTE 32 argument to be coerced to a bignum, requiring
  49   ;; consing, and thus generally obliterating performance.)
  50   (declare (optimize (speed 3) (safety 0)))
  51   (declare (type (and fixnum unsigned-byte) x y))
  52   ;; the ideas here:
  53   ;;   * Bits diffuse in both directions (shifted left by up to 2 places
  54   ;;     in the calculation of XY, and shifted right by up to 5 places
  55   ;;     by the ASH).
  56   ;;   * The #'+ and #'LOGXOR operations don't commute with each other,
  57   ;;     so different bit patterns are mixed together as they shift
  58   ;;     past each other.
  59   ;;   * The arbitrary constant in the #'LOGXOR expression is intended
  60   ;;     to help break up any weird anomalies we might otherwise get
  61   ;;     when hashing highly regular patterns.
  62   ;; (These are vaguely like the ideas used in many cryptographic
  63   ;; algorithms, but we're not pushing them hard enough here for them
  64   ;; to be cryptographically strong.)
  65   (let* ((xy (+ (* x 3) y)))
  66     (declare (type (unsigned-byte 32) xy))
  67     (the (and fixnum unsigned-byte)
  68          (logand most-positive-fixnum
  69                  (logxor 441516657
  70                          xy
  71                          (the fixnum (ash xy -5)))))))
  72 \f
  73 ;;;; hashing strings
  74 ;;;;
  75 ;;;; Note that this operation is used in compiler symbol table lookups, so we'd
  76 ;;;; like it to be fast.
  77
  78 #!-sb-fluid (declaim (inline %sxhash-substring))
  79 (defun %sxhash-substring (string &optional (count (length string)))
  80   ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
  81   ;; cross-compiler were smarter about ASH, but we need it for sbcl-0.5.0m.
  82   (declare (optimize (speed 3) (safety 0)))
  83   (declare (type string string))
  84   (declare (type index count))
  85   (let ((result 408967240))
  86     (declare (type fixnum result))
  87     (dotimes (i count)
  88       (declare (type index i))
  89       (mixf result
  90             (the fixnum
  91                  (ash (char-code (aref string i)) 5))))
  92     result))
  93 ;;; test:
  94 ;;;   (let ((ht (make-hash-table :test 'equal)))
  95 ;;;     (do-all-symbols (symbol)
  96 ;;;       (let* ((string (symbol-name symbol))
  97 ;;;           (hash (%sxhash-substring string)))
  98 ;;;      (if (gethash hash ht)
  99 ;;;          (unless (string= (gethash hash ht) string)
 100 ;;;            (format t "collision: ~S ~S~%" string (gethash hash ht)))
 101 ;;;          (setf (gethash hash ht) string))))
 102 ;;;     (format t "final count=~W~%" (hash-table-count ht)))
 103
 104 (defun %sxhash-simple-string (x)
 105   (declare (optimize speed))
 106   (declare (type simple-string x))
 107   (%sxhash-substring x))
 108
 109 (defun %sxhash-simple-substring (x count)
 110   (declare (optimize speed))
 111   (declare (type simple-string x))
 112   (declare (type index count))
 113   (%sxhash-substring x count))
 114 \f
 115 ;;;; the SXHASH function
 116
 117 (defun sxhash (x)
 118   (labels ((sxhash-number (x)
 119              (etypecase x
 120                (fixnum (sxhash x))      ; through DEFTRANSFORM
 121                (integer (sb!bignum:sxhash-bignum x))
 122                (single-float (sxhash x)) ; through DEFTRANSFORM
 123                (double-float (sxhash x)) ; through DEFTRANSFORM
 124                #!+long-float (long-float (error "stub: no LONG-FLOAT"))
 125                (ratio (let ((result 127810327))
 126                         (declare (type fixnum result))
 127                         (mixf result (sxhash-number (numerator x)))
 128                         (mixf result (sxhash-number (denominator x)))
 129                         result))
 130                (complex (let ((result 535698211))
 131                           (declare (type fixnum result))
 132                           (mixf result (sxhash-number (realpart x)))
 133                           (mixf result (sxhash-number (imagpart x)))
 134                           result))))
 135            (sxhash-recurse (x &optional (depthoid +max-hash-depthoid+))
 136              (declare (type index depthoid))
 137              (typecase x
 138                (list
 139                 (if (plusp depthoid)
 140                     (mix (sxhash-recurse (car x) (1- depthoid))
 141                          (sxhash-recurse (cdr x) (1- depthoid)))
 142                     261835505))
 143                (instance
 144                 (if (typep x 'structure-object)
 145                     (logxor 422371266
 146                             (sxhash ; through DEFTRANSFORM
 147                              (class-name (layout-class (%instance-layout x)))))
 148                     ;; Nice though it might be to return a nontrivial
 149                     ;; hash value for other instances (especially
 150                     ;; STANDARD-OBJECTs) there seems to be no good way
 151                     ;; to do so. We can't even do the CLASS-NAME trick
 152                     ;; (as used above for STRUCTURE-OBJECT) because
 153                     ;; then CHANGE-CLASS would cause SXHASH values to
 154                     ;; change, ouch! -- WHN recording wisdom of CSR
 155                     309518995))
 156                (symbol (sxhash x)) ; through DEFTRANSFORM
 157                (array
 158                 (typecase x
 159                   (simple-string (sxhash x)) ; through DEFTRANSFORM
 160                   (string (%sxhash-substring x))
 161                   (bit-vector (let ((result 410823708))
 162                                 (declare (type fixnum result))
 163                                 (dotimes (i (min depthoid (length x)))
 164                                   (mixf result (aref x i)))
 165                                 result))
 166                   (t (logxor 191020317 (sxhash (array-rank x))))))
 167                (character
 168                 (logxor 72185131
 169                         (sxhash (char-code x)))) ; through DEFTRANSFORM
 170                ;; general, inefficient case of NUMBER
 171                (number (sxhash-number x))
 172                (t 42))))
 173     (sxhash-recurse x)))
 174 \f
 175 ;;;; the PSXHASH function
 176
 177 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
 178 ;;;; more efficient (in both time and space) by rewriting it along the lines
 179 ;;;; of the SXHASH code above.
 180
 181 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
 182 (defun psxhash (key &optional (depthoid +max-hash-depthoid+))
 183   (declare (optimize speed))
 184   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 185   ;; Note: You might think it would be cleaner to use the ordering given in the
 186   ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
 187   ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
 188   ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
 189   ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
 190   ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
 191   ;; comparison behavior.
 192   (typecase key
 193     (array (array-psxhash key depthoid))
 194     (hash-table (hash-table-psxhash key))
 195     (structure-object (structure-object-psxhash key depthoid))
 196     (list (list-psxhash key depthoid))
 197     (number (number-psxhash key))
 198     (character (sxhash (char-upcase key)))
 199     (t (sxhash key))))
 200
 201 (defun array-psxhash (key depthoid)
 202   (declare (optimize speed))
 203   (declare (type array key))
 204   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 205   (typecase key
 206     ;; VECTORs have to be treated specially because ANSI specifies
 207     ;; that we must respect fill pointers.
 208     (vector
 209      (macrolet ((frob ()
 210                   '(let ((result 572539))
 211                      (declare (type fixnum result))
 212                      (mixf result (length key))
 213                      (dotimes (i (min depthoid (length key)))
 214                        (declare (type fixnum i))
 215                        (mixf result
 216                              (psxhash (aref key i)
 217                                       (- depthoid 1 i))))
 218                      result)))
 219        ;; CMU can compile SIMPLE-ARRAY operations so much more efficiently
 220        ;; than the general case that it's probably worth picking off the
 221        ;; common special cases.
 222        (typecase key
 223          (simple-string
 224           ;;(format t "~&SIMPLE-STRING special case~%")
 225           (frob))
 226          (simple-vector
 227           ;;(format t "~&SIMPLE-VECTOR special case~%")
 228           (frob))
 229          (t (frob)))))
 230     ;; Any other array can be hashed by working with its underlying
 231     ;; one-dimensional physical representation.
 232     (t
 233      (let ((result 60828))
 234        (declare (type fixnum result))
 235        (dotimes (i (min depthoid (array-rank key)))
 236          (mixf result (array-dimension key i)))
 237        (dotimes (i (min depthoid (array-total-size key)))
 238          (mixf result
 239                (psxhash (row-major-aref key i)
 240                         (- depthoid 1 i))))
 241        result))))
 242
 243 (defun structure-object-psxhash (key depthoid)
 244   (declare (optimize speed))
 245   (declare (type structure-object key))
 246   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 247   (let* ((layout (%instance-layout key)) ; i.e. slot #0
 248          (length (layout-length layout))
 249          (class (layout-class layout))
 250          (name (class-name class))
 251          (result (mix (sxhash name) (the fixnum 79867))))
 252     (declare (type fixnum result))
 253     (dotimes (i (min depthoid (1- length)))
 254       (declare (type fixnum i))
 255       (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT
 256         (declare (type fixnum j))
 257         (mixf result
 258               (psxhash (%instance-ref key j)
 259                        (1- depthoid)))))
 260     result))
 261
 262 (defun list-psxhash (key depthoid)
 263   (declare (optimize speed))
 264   (declare (type list key))
 265   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 266   (cond ((null key)
 267          (the fixnum 480929))
 268         ((zerop depthoid)
 269          (the fixnum 779578))
 270         (t
 271          (mix (psxhash (car key) (1- depthoid))
 272               (psxhash (cdr key) (1- depthoid))))))
 273
 274 (defun hash-table-psxhash (key)
 275   (declare (optimize speed))
 276   (declare (type hash-table key))
 277   (let ((result 103924836))
 278     (declare (type fixnum result))
 279     (mixf result (hash-table-count key))
 280     (mixf result (sxhash (hash-table-test key)))
 281     result))
 282
 283 (defun number-psxhash (key)
 284   (declare (optimize speed))
 285   (declare (type number key))
 286   (flet ((sxhash-double-float (val)
 287            (declare (type double-float val))
 288            ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
 289            ;; resulting code works without consing. (In Debian cmucl 2.4.17,
 290            ;; it didn't.)
 291            (sxhash val)))
 292     (etypecase key
 293       (integer (sxhash key))
 294       (float (macrolet ((frob (type)
 295                           (let ((lo (coerce most-negative-fixnum type))
 296                                 (hi (coerce most-positive-fixnum type)))
 297                             `(cond (;; This clause allows FIXNUM-sized integer
 298                                     ;; values to be handled without consing.
 299                                     (<= ,lo key ,hi)
 300                                     (multiple-value-bind (q r)
 301                                         (floor (the (,type ,lo ,hi) key))
 302                                       (if (zerop (the ,type r))
 303                                           (sxhash q)
 304                                           (sxhash-double-float
 305                                            (coerce key 'double-float)))))
 306                                    (t
 307                                     (multiple-value-bind (q r) (floor key)
 308                                       (if (zerop (the ,type r))
 309                                           (sxhash q)
 310                                           (sxhash-double-float
 311                                            (coerce key 'double-float)))))))))
 312                (etypecase key
 313                  (single-float (frob single-float))
 314                  (double-float (frob double-float))
 315                  (short-float (frob short-float))
 316                  (long-float (error "LONG-FLOAT not currently supported")))))
 317       (rational (if (and (<= most-negative-double-float
 318                              key
 319                              most-positive-double-float)
 320                          (= (coerce key 'double-float) key))
 321                     (sxhash-double-float (coerce key 'double-float))
 322                     (sxhash key)))
 323       (complex (if (zerop (imagpart key))
 324                    (number-psxhash (realpart key))
 325                    (let ((result 330231))
 326                      (declare (type fixnum result))
 327                      (mixf result (number-psxhash (realpart key)))
 328                      (mixf result (number-psxhash (imagpart key)))
 329                      result))))))