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 (file-comment
  15   "$Header$")
  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 (eval-when (:compile-toplevel :load-toplevel :execute)
  24 (defconstant +max-hash-depthoid+ 4)
  25 ) ; EVAL-WHEN
  26 \f
  27 ;;;; mixing hash values
  28
  29 ;;; a function for mixing hash values
  30 ;;;
  31 ;;; desiderata:
  32 ;;;   * Non-commutativity keeps us from hashing e.g. #(1 5) to the
  33 ;;;     same value as #(5 1), and ending up in real trouble in some
  34 ;;;     special cases like bit vectors the way that CMUCL SXHASH 18b
  35 ;;;     does. (Under CMUCL 18b, SXHASH of any bit vector is 1..)
  36 ;;;   * We'd like to scatter our hash values the entire possible range
  37 ;;;     of values instead of hashing small or common key values (like
  38 ;;;     2 and NIL and #\a) to small FIXNUMs the way that the CMUCL 18b
  39 ;;;     SXHASH function does, again helping to avoid pathologies like
  40 ;;;     hashing all bit vectors to 1.
  41 ;;;   * We'd like this to be simple and fast, too.
  42 ;;;
  43 ;;; FIXME: Should this be INLINE?
  44 (declaim (ftype (function ((and fixnum unsigned-byte)
  45                            (and fixnum unsigned-byte))
  46                           (and fixnum unsigned-byte)) mix))
  47 (defun mix (x y)
  48   ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
  49   ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,
  50   ;; and the (SAFETY 0) declaration here to get the compiler to trust
  51   ;; it, the sbcl-0.5.0m cross-compiler running under Debian
  52   ;; cmucl-2.4.17 turns the ASH into a full call, requiring the
  53   ;; UNSIGNED-BYTE 32 argument to be coerced to a bignum, requiring
  54   ;; consing, and thus generally obliterating performance.)
  55   (declare (optimize (speed 3) (safety 0)))
  56   (declare (type (and fixnum unsigned-byte) x y))
  57   ;; the ideas here:
  58   ;;   * Bits diffuse in both directions (shifted left by up to 2 places
  59   ;;     in the calculation of XY, and shifted right by up to 5 places
  60   ;;     by the ASH).
  61   ;;   * The #'+ and #'LOGXOR operations don't commute with each other,
  62   ;;     so different bit patterns are mixed together as they shift
  63   ;;     past each other.
  64   ;;   * The arbitrary constant in the #'LOGXOR expression is intended
  65   ;;     to help break up any weird anomalies we might otherwise get
  66   ;;     when hashing highly regular patterns.
  67   ;; (These are vaguely like the ideas used in many cryptographic
  68   ;; algorithms, but we're not pushing them hard enough here for them
  69   ;; to be cryptographically strong.)
  70   (let* ((xy (+ (* x 3) y)))
  71     (declare (type (unsigned-byte 32) xy))
  72     (the (and fixnum unsigned-byte)
  73          (logand most-positive-fixnum
  74                  (logxor 441516657
  75                          xy
  76                          (the fixnum (ash xy -5)))))))
  77 \f
  78 ;;;; hashing strings
  79 ;;;;
  80 ;;;; Note that this operation is used in compiler symbol table lookups, so we'd
  81 ;;;; like it to be fast.
  82
  83 #!-sb-fluid (declaim (inline %sxhash-substring))
  84 (defun %sxhash-substring (string &optional (count (length string)))
  85   ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
  86   ;; cross-compiler were smarter about ASH, but we need it for sbcl-0.5.0m.
  87   (declare (optimize (speed 3) (safety 0)))
  88   (declare (type string string))
  89   (declare (type index count))
  90   (let ((result 408967240))
  91     (declare (type fixnum result))
  92     (dotimes (i count)
  93       (declare (type index i))
  94       (mixf result
  95             (the fixnum
  96                  (ash (char-code (aref string i)) 5))))
  97     result))
  98 ;;; test:
  99 ;;;   (let ((ht (make-hash-table :test 'equal)))
 100 ;;;     (do-all-symbols (symbol)
 101 ;;;       (let* ((string (symbol-name symbol))
 102 ;;;           (hash (%sxhash-substring string)))
 103 ;;;      (if (gethash hash ht)
 104 ;;;          (unless (string= (gethash hash ht) string)
 105 ;;;            (format t "collision: ~S ~S~%" string (gethash hash ht)))
 106 ;;;          (setf (gethash hash ht) string))))
 107 ;;;     (format t "final count=~D~%" (hash-table-count ht)))
 108
 109 (defun %sxhash-simple-string (x)
 110   (declare (optimize speed))
 111   (declare (type simple-string x))
 112   (%sxhash-substring x))
 113
 114 (defun %sxhash-simple-substring (x count)
 115   (declare (optimize speed))
 116   (declare (type simple-string x))
 117   (declare (type index count))
 118   (%sxhash-substring x count))
 119 \f
 120 ;;;; the SXHASH function
 121
 122 (defun sxhash (x)
 123   (labels ((sxhash-number (x)
 124              (etypecase x
 125                (fixnum (sxhash x)) ; through DEFTRANSFORM
 126                (integer (sb!bignum:sxhash-bignum x))
 127                (single-float (sxhash x)) ; through DEFTRANSFORM
 128                (double-float (sxhash x)) ; through DEFTRANSFORM
 129                #!+long-float (long-float (error "stub: no LONG-FLOAT"))
 130                (ratio (let ((result 127810327))
 131                         (declare (type fixnum result))
 132                         (mixf result (sxhash-number (numerator x)))
 133                         (mixf result (sxhash-number (denominator x)))
 134                         result))
 135                (complex (let ((result 535698211))
 136                           (declare (type fixnum result))
 137                           (mixf result (sxhash-number (realpart x)))
 138                           (mixf result (sxhash-number (imagpart x)))
 139                           result))))
 140            (sxhash-recurse (x &optional (depthoid +max-hash-depthoid+))
 141              (declare (type index depthoid))
 142              (typecase x
 143                (list
 144                 (if (plusp depthoid)
 145                     (mix (sxhash-recurse (car x) (1- depthoid))
 146                          (sxhash-recurse (cdr x) (1- depthoid)))
 147                     261835505))
 148                (instance
 149                 (if (typep x 'structure-object)
 150                     (logxor 422371266
 151                             (sxhash ; through DEFTRANSFORM
 152                              (class-name (layout-class (%instance-layout x)))))
 153                     309518995))
 154                (symbol (sxhash x)) ; through DEFTRANSFORM
 155                (number (sxhash-number x))
 156                (array
 157                 (typecase x
 158                   (simple-string (sxhash x)) ; through DEFTRANSFORM
 159                   (string (%sxhash-substring x))
 160                   (bit-vector (let ((result 410823708))
 161                                 (declare (type fixnum result))
 162                                 (dotimes (i (min depthoid (length x)))
 163                                   (mixf result (aref x i)))
 164                                 result))
 165                   (t (logxor 191020317 (sxhash (array-rank x))))))
 166                (character
 167                 (logxor 72185131
 168                         (sxhash (char-code x)))) ; through DEFTRANSFORM
 169                (t 42))))
 170     (sxhash-recurse x)))
 171 \f
 172 ;;;; the PSXHASH function
 173
 174 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
 175 ;;;; more efficient (in both time and space) by rewriting it along the lines
 176 ;;;; of the SXHASH code above.
 177
 178 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
 179 (defun psxhash (key &optional (depthoid +max-hash-depthoid+))
 180   (declare (optimize speed))
 181   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 182   ;; Note: You might think it would be cleaner to use the ordering given in the
 183   ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
 184   ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
 185   ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
 186   ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
 187   ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
 188   ;; comparison behavior.
 189   (typecase key
 190     (array (array-psxhash key depthoid))
 191     (hash-table (hash-table-psxhash key))
 192     (structure-object (structure-object-psxhash key depthoid))
 193     (list (list-psxhash key depthoid))
 194     (number (number-psxhash key))
 195     (character (sxhash (char-upcase key)))
 196     (t (sxhash key))))
 197
 198 (defun array-psxhash (key depthoid)
 199   (declare (optimize speed))
 200   (declare (type array key))
 201   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 202   (typecase key
 203     ;; VECTORs have to be treated specially because ANSI specifies
 204     ;; that we must respect fill pointers.
 205     (vector
 206      (macrolet ((frob ()
 207                   '(let ((result 572539))
 208                      (declare (type fixnum result))
 209                      (mixf result (length key))
 210                      (dotimes (i (min depthoid (length key)))
 211                        (declare (type fixnum i))
 212                        (mixf result
 213                              (psxhash (aref key i)
 214                                       (- depthoid 1 i))))
 215                      result)))
 216        ;; CMU can compile SIMPLE-ARRAY operations so much more efficiently
 217        ;; than the general case that it's probably worth picking off the
 218        ;; common special cases.
 219        (typecase key
 220          (simple-string
 221           ;;(format t "~&SIMPLE-STRING special case~%")
 222           (frob))
 223          (simple-vector
 224           ;;(format t "~&SIMPLE-VECTOR special case~%")
 225           (frob))
 226          (t (frob)))))
 227     ;; Any other array can be hashed by working with its underlying
 228     ;; one-dimensional physical representation.
 229     (t
 230      (let ((result 60828))
 231        (declare (type fixnum result))
 232        (dotimes (i (min depthoid (array-rank key)))
 233          (mixf result (array-dimension key i)))
 234        (dotimes (i (min depthoid (array-total-size key)))
 235          (mixf result
 236                (psxhash (row-major-aref key i)
 237                         (- depthoid 1 i))))
 238        result))))
 239
 240 (defun structure-object-psxhash (key depthoid)
 241   (declare (optimize speed))
 242   (declare (type structure-object key))
 243   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 244   (let* ((layout (%instance-layout key)) ; i.e. slot #0
 245          (length (layout-length layout))
 246          (class (layout-class layout))
 247          (name (class-name class))
 248          (result (mix (sxhash name) (the fixnum 79867))))
 249     (declare (type fixnum result))
 250     (dotimes (i (min depthoid (1- length)))
 251       (declare (type fixnum i))
 252       (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT
 253         (declare (type fixnum j))
 254         (mixf result
 255               (psxhash (%instance-ref key j)
 256                        (1- depthoid)))))
 257     result))
 258
 259 (defun list-psxhash (key depthoid)
 260   (declare (optimize speed))
 261   (declare (type list key))
 262   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
 263   (cond ((null key)
 264          (the fixnum 480929))
 265         ((zerop depthoid)
 266          (the fixnum 779578))
 267         (t
 268          (mix (psxhash (car key) (1- depthoid))
 269               (psxhash (cdr key) (1- depthoid))))))
 270
 271 (defun hash-table-psxhash (key)
 272   (declare (optimize speed))
 273   (declare (type hash-table key))
 274   (let ((result 103924836))
 275     (declare (type fixnum result))
 276     (mixf result (hash-table-count key))
 277     (mixf result (sxhash (hash-table-test key)))
 278     result))
 279
 280 (defun number-psxhash (key)
 281   (declare (optimize speed))
 282   (declare (type number key))
 283   (flet ((sxhash-double-float (val)
 284            (declare (type double-float val))
 285            ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
 286            ;; resulting code works without consing. (In Debian cmucl 2.4.17,
 287            ;; it didn't.)
 288            (sxhash val)))
 289     (etypecase key
 290       (integer (sxhash key))
 291       (float (macrolet ((frob (type)
 292                           (let ((lo (coerce most-negative-fixnum type))
 293                                 (hi (coerce most-positive-fixnum type)))
 294                             `(cond (;; This clause allows FIXNUM-sized integer
 295                                     ;; values to be handled without consing.
 296                                     (<= ,lo key ,hi)
 297                                     (multiple-value-bind (q r)
 298                                         (floor (the (,type ,lo ,hi) key))
 299                                       (if (zerop (the ,type r))
 300                                           (sxhash q)
 301                                           (sxhash-double-float
 302                                            (coerce key 'double-float)))))
 303                                    (t
 304                                     (multiple-value-bind (q r) (floor key)
 305                                       (if (zerop (the ,type r))
 306                                           (sxhash q)
 307                                           (sxhash-double-float
 308                                            (coerce key 'double-float)))))))))
 309                (etypecase key
 310                  (single-float (frob single-float))
 311                  (double-float (frob double-float))
 312                  (short-float (frob short-float))
 313                  (long-float (error "LONG-FLOAT not currently supported")))))
 314       (rational (if (and (<= most-negative-double-float
 315                              key
 316                              most-positive-double-float)
 317                          (= (coerce key 'double-float) key))
 318                     (sxhash-double-float (coerce key 'double-float))
 319                     (sxhash key)))
 320       (complex (if (zerop (imagpart key))
 321                    (number-psxhash (realpart key))
 322                    (let ((result 330231))
 323                      (declare (type fixnum result))
 324                      (mixf result (number-psxhash (realpart key)))
 325                      (mixf result (number-psxhash (imagpart key)))
 326                      result))))))
 327
 328 ;;; SXHASH and PSXHASH should distribute hash values well over the
 329 ;;; space of possible values, so that collisions between the hash values
 330 ;;; of unequal objects should be very uncommon.
 331 ;;;
 332 ;;; FIXME: These tests should be enabled once the rest of the system is
 333 ;;; stable. (For now, I don't want to mess with things like making sure
 334 ;;; that bignums are hashed uniquely.)
 335 ;;;#!+sb-test
 336 #+nil
 337 (let* ((test-cases `((0 . 1)
 338                      (0 . 1)
 339                      (1 . 0)
 340                      ((1 . 0) (0 . 0))
 341                      ((0 . 1) (0 . 0))
 342                      ((0 . 0) (1 . 0))
 343                      ((0 . 0) (0 . 1))
 344                      #((1 . 0) (0 . 0))
 345                      #((0 . 1) (0 . 0))
 346                      #((0 . 0) (1 . 0))
 347                      #((0 . 0) (0 . 1))
 348                      #((1 . 0) (0 . 0))
 349                      #((0 1) (0 0))
 350                      #((0 0) (1 0))
 351                      #((0 0) (0 1))
 352                      #(#(1 0) (0 0))
 353                      #(#(0 1) (0 0))
 354                      #(#(0 0) (1 0))
 355                      #(#(0 0) (0 1))
 356                      #(#*00 #*10)
 357                      #(#(0 0) (0 1.0d0))
 358                      #(#(-0.0d0 0) (1.0 0))
 359                      ;; KLUDGE: Some multi-dimensional array test cases would
 360                      ;; be good here too, but currently SBCL isn't smart enough
 361                      ;; to dump them as literals, and I'm too lazy to make
 362                      ;; code to create them at run time. -- WHN 20000111
 363                      44 44.0 44.0d0
 364                      44 44.0 44.0d0
 365                      -44 -44.0 -44.0d0
 366                      0 0.0 0.0d0
 367                      -0 -0.0 -0.0d0
 368                      -121 -121.0 -121.0d0
 369                      3/4 0.75 0.75d0
 370                      -3/4 -0.75 -0.75d0
 371                      44.1 44.1d0
 372                      45 45.0 45.0d0
 373                      ,(expt 2 33) ,(expt 2.0 33) ,(expt 2.0d0 33)
 374                      ,(- (expt 1/2 50)) ,(- (expt 0.5 50)) ,(- (expt 0.5d0 50))
 375                      ,(- (expt 1/2 50)) ,(- (expt 0.5 50)) ,(- (expt 0.5d0 50))
 376                      #c(1.0 2.0) #c(1 2.0) #c(1.5 -3/2) #c(3/2 -3/2) #c(0 1)
 377                      #c(1.0 2.0) #c(1 2.0) #c(1.5 -3/2) #c(3/2 -3/2) #c(0 1)
 378                      ,(make-hash-table)
 379                      ,(make-hash-table :test 'equal)
 380                      "abc" "ABC" "aBc" 'abc #(#\a #\b #\c) #(a b c) #("A" b c)
 381                      "abcc"
 382                      "" #* #() () (()) #(()) (#())
 383                      "" #* #() () (()) #(()) (#())
 384                      #\x #\X #\*
 385                      #\x #\X #\*)))
 386   (dolist (i test-cases)
 387     (unless (typep (sxhash i) '(and fixnum unsigned-byte))
 388       (error "bad SXHASH behavior for ~S" i))
 389     (unless (typep (psxhash i) '(and fixnum unsigned-byte))
 390       (error "bad PSXHASH behavior for ~S" i))
 391     (dolist (j test-cases)
 392       (flet ((t->boolean (x) (if x t nil)))
 393         ;; Note: It's possible that a change to the hashing algorithm could
 394         ;; leave it correct but still cause this test to bomb by causing an
 395         ;; unlucky random collision. That's not very likely (since there are
 396         ;; (EXPT 2 29) possible hash values and only on the order of 100 test
 397         ;; cases, but it's probably worth checking if you are getting a
 398         ;; mystifying error from this test.
 399         (unless (eq (t->boolean (equal i j))
 400                     (t->boolean (= (sxhash i) (sxhash j))))
 401           (error "bad SXHASH behavior for ~S ~S" i j))
 402         (unless (eq (t->boolean (equalp i j))
 403                     (t->boolean (= (psxhash i) (psxhash j))))
 404           (error "bad PSXHASH behavior for ~S ~S" i j))))))
 405
 406 ;;; FIXME: Test that the the hash functions can deal with common cases without
 407 ;;; consing.
 408 ;(defun consless-test ()
 409 ;  (dotimes (j 100000)
 410 ;    (dolist (i '("yo" #(1 2 3) #2A((1 2) (1 2)) (1 2 (3)) 1 1.0 1.0d0))
 411 ;      (psxhash i))))