1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
14 (use-package :test-util)
15 (use-package :assertoid)
20 ;;; SXHASH and PSXHASH should distribute hash values well over the
21 ;;; space of possible values, so that collisions between the hash
22 ;;; values of unequal objects should be very uncommon. (Except of
23 ;;; course the hash values must collide when the objects are EQUAL or
24 ;;; EQUALP respectively!)
26 ;; In order to better test not-EQ-but-EQUAL and not-EQ-but-EQUALP,
27 ;; we'd like to suppress some optimizations.
28 (declare (notinline complex float coerce + - expt))
29 (flet ((make-sxhash-subtests ()
33 (cons (cons 1 0) (cons 0 0))
34 (cons (list 1 0) (list 0 0))
35 (list (cons 1 0) (list 0 0))
36 (list (cons 0 1) (list 0 0))
37 (list (cons 0 0) (cons 1 0))
38 (list (cons 0 0) (cons 0 1))
40 44 (float 44) (coerce 44 'double-float)
41 -44 (float -44) (coerce -44 'double-float)
42 0 (float 0) (coerce 0 'double-float)
43 -0 (- (float 0)) (- (coerce 0 'double-float))
44 -121 (float -121) (coerce -121 'double-float)
45 3/4 (float 3/4) (coerce 3/4 'double-float)
46 -3/4 (float -3/4) (coerce -3/4 'double-float)
47 45 (float 45) (coerce 45 'double-float)
48 441/10 (float 441/10) (coerce (float 441/10) 'double-float)
50 (expt 2 33) (expt 2.0 33) (expt 2.0d0 33)
51 (- (expt 1/2 50)) (- (expt 0.5 50)) (- (expt 0.5d0 50))
52 (+ (expt 1/2 50)) (+ (expt 0.5 50)) (+ (expt 0.5d0 50))
54 (complex 1.0 2.0) (complex 1.0d0 2.0)
55 (complex 1.5 -3/2) (complex 1.5 -1.5d0)
59 (copy-seq "foo") (copy-seq "foobar") (copy-seq "foobarbaz")
62 (copy-seq #*0) (copy-seq #*1)
63 (copy-seq #*00) (copy-seq #*10)
64 (copy-seq #*01) (copy-seq #*11)
65 (copy-seq #*10010) (copy-seq #*100101) (bit-not #*01101)
66 (make-array 6 :fill-pointer 6
67 :element-type 'bit :initial-contents #*100101)
69 #'allocate-instance #'no-applicable-method))
70 (make-psxhash-extra-subtests ()
78 (make-array 3 :fill-pointer 0)
79 (make-array 7 :fill-pointer 0 :element-type 'bit)
80 (make-array 8 :fill-pointer 0 :element-type 'character)
81 (vector (cons 1 0) (cons 0 0))
82 (vector (cons 0 1) (cons 0 0))
83 (vector (cons 0 0) (cons 1 0))
84 (vector (cons 0 0) (cons 0 1))
85 (vector (cons 1 0) (cons 0 0))
86 (vector (cons 0 1) (cons 0 0))
87 (vector (list 0 0) (cons 1 0))
88 (vector (list 0 0) (list 0 1))
89 (vector (vector 1 0) (list 0 0))
90 (vector (vector 0 1) (list 0 0))
91 (vector (vector 0 0) (list 1 0))
92 (vector (vector 0 0) (list 0 1))
94 (vector (vector 0 0) (list 0 1.0d0))
95 (vector (vector -0.0d0 0) (list 1.0 0))
100 (replace (make-array 101
104 (replace (make-array 14
105 :element-type '(unsigned-byte 8)
108 (replace (make-array 14
121 (replace (make-array 14
122 :element-type 'character
125 (replace (make-array 11
126 :element-type 'character
129 (replace (make-array 12
133 (replace (make-array 13
137 (replace (make-array 13
141 ;; FIXME: What about multi-dimensional arrays, hmm?
144 (make-hash-table :test 'equal)
148 (make-bar :x (list 1))
149 (make-bar :y (list 1))))
150 (t->boolean (x) (if x t nil)))
152 ;; * The APPEND noise here is to help more strenuously test
153 ;; not-EQ-but-EQUAL and not-EQ-but-EQUALP cases.
154 ;; * It seems not to be worth the hassle testing SXHASH on
155 ;; values whose structure isn't understood by EQUAL, since
156 ;; we get too many false positives "SXHASHes are equal even
157 ;; though values aren't EQUAL, what a crummy hash function!"
158 ;; FIXME: Or am I misunderstanding the intent of the
159 ;; the SXHASH specification? Perhaps SXHASH is supposed to
160 ;; descend into the structure of objects even when EQUAL
161 ;; doesn't, in order to avoid hashing together things which
162 ;; are guaranteed not to be EQUAL? The definition of SXHASH
163 ;; seems to leave this completely unspecified: should
164 ;; "well-distributed" depend on substructure that EQUAL
165 ;; ignores? For our internal hash tables, the stricter
166 ;; descend-into-the-structure behavior might improve
167 ;; performance even though it's not specified by ANSI. But
168 ;; is it reasonable for users to expect it? Hmm..
169 (sxhash-tests (append (make-sxhash-subtests)
170 (make-sxhash-subtests)))
171 (psxhash-tests (append sxhash-tests
172 (make-psxhash-extra-subtests)
173 (make-psxhash-extra-subtests))))
174 ;; Check that SXHASH compiler transforms give the same results
175 ;; as the out-of-line version of SXHASH.
176 (let* ((fundef `(lambda ()
177 (list ,@(mapcar (lambda (value)
180 (fun (compile nil fundef)))
181 (assert (equal (funcall fun)
182 (mapcar #'sxhash sxhash-tests))))
183 ;; Note: The tests for SXHASH-equality iff EQUAL and
184 ;; PSXHASH-equality iff EQUALP could fail because of an unlucky
185 ;; random collision. That's not very likely (since there are
186 ;; (EXPT 2 29) possible hash values and only on the order of 100
187 ;; test cases, so even with the birthday paradox a collision has
188 ;; probability only (/ (EXPT 100 2) (EXPT 2 29)), but it's
189 ;; probably worth checking if you are getting a mystifying error
190 ;; from this test. (SXHASH values and PSXHASH values don't
191 ;; change from run to run, so the random chance of bogus failure
192 ;; happens once every time the code is changed in such a way
193 ;; that the SXHASH distribution changes, not once every time the
195 (dolist (i sxhash-tests)
196 (declare (notinline funcall))
197 (unless (typep (funcall #'sxhash i) '(and fixnum unsigned-byte))
198 (error "bad SXHASH behavior for ~S" i))
199 (dolist (j sxhash-tests)
200 (unless (or (eq (t->boolean (equal i j))
201 (t->boolean (= (sxhash i) (sxhash j))))
202 (and (typep i 'number)
205 (subtypep (type-of i) (type-of j))
206 (subtypep (type-of j) (type-of i))))
207 ;; (If you get a surprising failure here, maybe you were
208 ;; just very unlucky; see the notes above.)
209 (error "bad SXHASH behavior for ~S ~S" i j))))
210 (dolist (i psxhash-tests)
211 (unless (typep (sb-int:psxhash i) '(and fixnum unsigned-byte))
212 (error "bad PSXHASH behavior for ~S" i))
213 (dolist (j psxhash-tests)
214 (unless (eq (t->boolean (equalp i j))
215 (t->boolean (= (sb-int:psxhash i) (sb-int:psxhash j))))
216 ;; (If you get a surprising failure here, maybe you were
217 ;; just very unlucky; see the notes above.)
218 (error "bad PSXHASH behavior for ~S ~S" i j))))
221 ;;; As of sbcl-0.6.12.10, writing hash tables readably should work.
222 ;;; This isn't required by the ANSI standard, but it should be, since
223 ;;; it's well-defined useful behavior which ANSI prohibits the users
224 ;;; from implementing themselves. (ANSI says the users can't define
225 ;;; their own their own PRINT-OBJECT (HASH-TABLE T) methods, and they
226 ;;; can't even wiggle out of it by subclassing HASH-TABLE or STREAM.)
227 (let ((original-ht (make-hash-table :test 'equal :size 111))
228 (original-keys '(1 10 11 400030002 -100000000)))
229 (dolist (key original-keys)
230 (setf (gethash key original-ht)
232 (let* ((written-ht (with-output-to-string (s)
233 (write original-ht :stream s :readably t)))
234 (read-ht (with-input-from-string (s written-ht)
236 (assert (= (hash-table-count read-ht)
237 (hash-table-count original-ht)
238 (length original-keys)))
239 (assert (eql (hash-table-test original-ht) (hash-table-test read-ht)))
240 (assert (eql (hash-table-size original-ht) (hash-table-size read-ht)))
241 (dolist (key original-keys)
242 (assert (eql (gethash key read-ht)
243 (gethash key original-ht))))))
245 ;;; NIL is both SYMBOL and LIST
246 (dolist (fun '(sxhash sb-impl::psxhash))
247 (assert (= (eval `(,fun nil))
249 (funcall (compile nil `(lambda (x)
253 (funcall (compile nil `(lambda (x)
257 (funcall (compile nil `(lambda (x)
262 ;;; This test works reliably on non-conservative platforms and
263 ;;; somewhat reliably on conservative platforms with threads.
266 (defparameter *ht* nil)
270 (declaim (notinline args))
271 (defun take (&rest args)
272 (declare (ignore args)))
274 (defmacro alloc (&body body)
275 "Execute BODY and try to reduce the chance of leaking a conservative root."
277 `(multiple-value-prog1
279 (loop repeat 20000 do (setq *cons-here* (cons nil nil)))
280 ;; KLUDGE: Clean the argument passing regs.
281 (apply #'take (loop repeat 36 collect #'cons)))
283 (let ((values (gensym))
285 `(let ((,sem (sb-thread::make-semaphore))
287 (make-join-thread (lambda ()
289 (multiple-value-list (progn ,@body)))
290 (sb-thread::signal-semaphore ,sem)))
291 (sb-thread::wait-on-semaphore ,sem)
292 (values-list ,values))))
294 (with-test (:name (:hash-table :weakness :eql :numbers) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
295 (flet ((random-number ()
297 (loop for weakness in '(nil :key :value :key-and-value :key-or-value) do
298 (let* ((ht (make-hash-table :weakness weakness))
299 (n (alloc (loop repeat 1000
300 count (let ((key (random-number)))
302 (setf (gethash key ht)
303 (random-number))))))))
306 (assert (= n (hash-table-count ht)))))))
308 (defun add-removable-stuff (ht &key (n 100) (size 10))
309 (flet ((unique-object ()
310 (make-array size :fill-pointer 0)))
311 (loop for i below n do
312 (multiple-value-bind (key value)
313 (ecase (hash-table-weakness ht)
314 ((:key) (values (unique-object) i))
315 ((:value) (values i (unique-object)))
317 (if (zerop (random 2))
318 (values (unique-object) i)
319 (values i (unique-object))))
321 (values (unique-object) (unique-object))))
322 (setf (gethash key ht) value)))
325 (defun print-ht (ht &optional (stream t))
326 (format stream "Weakness: ~S~%" (sb-impl::hash-table-weakness ht))
327 (format stream "Table: ~S~%" (sb-impl::hash-table-table ht))
328 (format stream "Next: ~S~%" (sb-impl::hash-table-next-vector ht))
329 (format stream "Index: ~S~%" (sb-impl::hash-table-index-vector ht))
330 (format stream "Hash: ~S~%" (sb-impl::hash-table-hash-vector ht))
331 (force-output stream))
333 (with-test (:name (:hash-table :weakness :removal) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
334 (loop for test in '(eq eql equal equalp) do
335 (format t "test: ~A~%" test)
336 (loop for weakness in '(:key :value :key-and-value :key-or-value)
338 (format t "weakness: ~A~%" weakness)
339 (let ((ht (make-hash-table :test 'equal :weakness weakness)))
340 (alloc (add-removable-stuff ht :n 117 :size 1))
342 do (format t "~A. count: ~A~%" i (hash-table-count ht))
344 until (zerop (hash-table-count ht))
350 ;; With conservative gc the test may not be
351 ;; bullet-proof so it's not an outright
352 ;; failure but a warning.
355 (warn "Weak hash removal test failed for weakness ~A"
360 (with-test (:name (:hash-table :weakness :string-interning) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
361 (let ((ht (make-hash-table :test 'equal :weakness :key))
363 (setf (gethash s ht) s)
364 (assert (eq (gethash s ht) s))
365 (assert (eq (gethash (copy-seq s) ht) s))))
367 ;;; see if hash_vector is not written when there is none ...
368 (with-test (:name (:hash-table :weakness :eq) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
370 (let ((index (random 2000)))
371 (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
373 (let ((hash-table (make-hash-table :weakness :key :test 'eq)))
375 (setf (gethash (+ first i) hash-table) i))
378 ;; used to crash in gc
379 (with-test (:name (:hash-table :weakness :keep) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
381 (let ((h1 (make-hash-table :weakness :key :test #'equal))
383 (loop for i from 0 to 1000
385 for value = (make-array 10000 :fill-pointer 0)
388 (setf (gethash key h1) value))
389 (sb-ext:gc :full t))))
393 ;;; DEFINE-HASH-TABLE-TEST
395 (defstruct custom-hash-key name)
396 (defun custom-hash-test (x y)
397 (equal (custom-hash-key-name x)
398 (custom-hash-key-name y)))
399 (defun custom-hash-hash (x)
400 (sxhash (custom-hash-key-name x)))
401 (define-hash-table-test custom-hash-test custom-hash-hash)
402 (with-test (:name :define-hash-table-test.1)
403 (let ((table (make-hash-table :test 'custom-hash-test)))
404 (setf (gethash (make-custom-hash-key :name "foo") table) :foo)
405 (setf (gethash (make-custom-hash-key :name "bar") table) :bar)
406 (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table)))
407 (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table)))
408 (assert (eq 'custom-hash-test (hash-table-test table))))
409 (let ((table (make-hash-table :test #'custom-hash-test)))
410 (setf (gethash (make-custom-hash-key :name "foo") table) :foo)
411 (setf (gethash (make-custom-hash-key :name "bar") table) :bar)
412 (assert (eq :foo (gethash (make-custom-hash-key :name "foo") table)))
413 (assert (eq :bar (gethash (make-custom-hash-key :name "bar") table)))
414 (assert (eq 'custom-hash-test (hash-table-test table)))))
417 (defun head-eql (x y)
418 (every #'eql (subseq x 0 3) (subseq y 0 3)))
419 (define-hash-table-test head-eql
421 (logand most-positive-fixnum
422 (reduce #'+ (map 'list #'sxhash (subseq x 0 3))))))
423 (with-test (:name :define-hash-table-test.2)
424 (let ((table (make-hash-table :test 'head-eql)))
425 (setf (gethash #(1 2 3 4) table) :|123|)
426 (setf (gethash '(2 3 4 7) table) :|234|)
427 (setf (gethash "foobar" table) :foo)
428 (assert (eq :|123| (gethash '(1 2 3 ! 6) table)))
429 (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table)))
430 (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table)))
431 (assert (eq 'head-eql (hash-table-test table))))
432 (let ((table (make-hash-table :test #'head-eql)))
433 (setf (gethash #(1 2 3 4) table) :|123|)
434 (setf (gethash '(2 3 4 7) table) :|234|)
435 (setf (gethash "foobar" table) :foo)
436 (assert (eq :|123| (gethash '(1 2 3 ! 6) table)))
437 (assert (eq :|234| (gethash #(2 3 4 0 2 1 a) table)))
438 (assert (eq :foo (gethash '(#\f #\o #\o 1 2 3) table)))
439 (assert (eq 'head-eql (hash-table-test table)))))
441 (with-test (:name :make-hash-table/hash-fun)
442 (let ((table (make-hash-table
444 :hash-function (lambda (x)
445 (sxhash (coerce (abs x) 'double-float))))))
446 (incf (gethash 1 table 0))
447 (incf (gethash 1.0f0 table))
448 (incf (gethash 1.0d0 table))
449 (incf (gethash (complex 1.0f0 0.0f0) table))
450 (incf (gethash (complex 1.0d0 0.0d0) table))
451 (assert (= 5 (gethash 1 table)))
452 (assert (eq '= (hash-table-test table)))))