Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / hash.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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
6 ;;;; from CMU CL.
7 ;;;;
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.
11
12 (in-package :cl-user)
13
14 (use-package :test-util)
15 (use-package :assertoid)
16
17 (defstruct foo)
18 (defstruct bar x y)
19
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!)
25 (locally
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 ()
30            (list (cons 0 1)
31                  (list 0 1)
32                  (cons 1 0)
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))
39
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)
49
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))
53
54                  (complex 1.0 2.0) (complex 1.0d0 2.0)
55                  (complex 1.5 -3/2) (complex 1.5 -1.5d0)
56
57                  #\x #\X #\*
58
59                  (copy-seq "foo") (copy-seq "foobar") (copy-seq "foobarbaz")
60
61                  (copy-seq #*)
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)
68
69                  #'allocate-instance #'no-applicable-method))
70          (make-psxhash-extra-subtests ()
71            (list (copy-seq "")
72                  (copy-seq #*)
73                  (copy-seq #())
74                  (copy-seq ())
75                  (copy-seq '(()))
76                  (copy-seq #(()))
77                  (copy-seq '(#()))
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))
93                  (vector #*00 #*10)
94                  (vector (vector 0 0) (list 0 1.0d0))
95                  (vector (vector -0.0d0 0) (list 1.0 0))
96                  (vector 1 0 1 0)
97                  (vector 0 0 0)
98                  (copy-seq #*1010)
99                  (copy-seq #*000)
100                  (replace (make-array 101
101                                       :element-type 'bit
102                                       :fill-pointer 4)
103                           #*1010)
104                  (replace (make-array 14
105                                       :element-type '(unsigned-byte 8)
106                                       :fill-pointer 3)
107                           #*000)
108                  (replace (make-array 14
109                                       :element-type t
110                                       :fill-pointer 3)
111                           #*000)
112                  (copy-seq "abc")
113                  (copy-seq "ABC")
114                  (copy-seq "aBc")
115                  (copy-seq "abcc")
116                  (copy-seq "1001")
117                  'abc
118                  (vector #\a #\b #\c)
119                  (vector 'a 'b 'c)
120                  (vector "A" 'b 'c)
121                  (replace (make-array 14
122                                       :element-type 'character
123                                       :fill-pointer 3)
124                           "aBc")
125                  (replace (make-array 11
126                                       :element-type 'character
127                                       :fill-pointer 4)
128                           "1001")
129                  (replace (make-array 12
130                                       :element-type 'bit
131                                       :fill-pointer 4)
132                           #*1001)
133                  (replace (make-array 13
134                                       :element-type t
135                                       :fill-pointer 4)
136                           "1001")
137                  (replace (make-array 13
138                                       :element-type t
139                                       :fill-pointer 4)
140                           #*1001)
141                  ;; FIXME: What about multi-dimensional arrays, hmm?
142
143                  (make-hash-table)
144                  (make-hash-table :test 'equal)
145
146                  (make-foo)
147                  (make-bar)
148                  (make-bar :x (list 1))
149                  (make-bar :y (list 1))))
150          (t->boolean (x) (if x t nil)))
151     (let* (;; Note:
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)
178                                           `(sxhash ',value))
179                                         sxhash-tests))))
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
194       ;; tests are run.)
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)
203                            (typep j 'number)
204                            (= i j)
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))))
219       )))
220
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)
231           (expt key 4)))
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)
235                     (read s))))
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))))))
244
245 ;;; NIL is both SYMBOL and LIST
246 (dolist (fun '(sxhash sb-impl::psxhash))
247   (assert (= (eval `(,fun nil))
248              (funcall fun nil)
249              (funcall (compile nil `(lambda (x)
250                                       (declare (symbol x))
251                                       (,fun x)))
252                       nil)
253              (funcall (compile nil `(lambda (x)
254                                       (declare (list x))
255                                       (,fun x)))
256                       nil)
257              (funcall (compile nil `(lambda (x)
258                                       (declare (null x))
259                                       (,fun x)))
260                       nil))))
261
262 ;;; This test works reliably on non-conservative platforms and
263 ;;; somewhat reliably on conservative platforms with threads.
264 (progn
265
266 (defparameter *ht* nil)
267
268 (defvar *cons-here*)
269
270 (declaim (notinline args))
271 (defun take (&rest args)
272   (declare (ignore args)))
273
274 (defmacro alloc (&body body)
275   "Execute BODY and try to reduce the chance of leaking a conservative root."
276   #-sb-thread
277   `(multiple-value-prog1
278        (progn ,@body)
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)))
282   #+sb-thread
283   (let ((values (gensym))
284         (sem (gensym)))
285     `(let ((,sem (sb-thread::make-semaphore))
286            ,values)
287        (make-join-thread (lambda ()
288                            (setq ,values
289                                  (multiple-value-list (progn ,@body)))
290                            (sb-thread::signal-semaphore ,sem)))
291        (sb-thread::wait-on-semaphore ,sem)
292        (values-list ,values))))
293
294 (with-test (:name (:hash-table :weakness :eql :numbers) :skipped-on '(and :c-stack-is-control-stack (not :sb-thread)))
295   (flet ((random-number ()
296            (random 1000)))
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)))
301                                          (if (gethash key ht)
302                                              (setf (gethash key ht)
303                                                    (random-number))))))))
304             (gc :full t)
305             (gc :full t)
306             (assert (= n (hash-table-count ht)))))))
307
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)))
316                 ((:key-and-value)
317                  (if (zerop (random 2))
318                      (values (unique-object) i)
319                      (values i (unique-object))))
320                 ((:key-or-value)
321                  (values (unique-object) (unique-object))))
322             (setf (gethash key ht) value)))
323     (values)))
324
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))
332
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)
337               do
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))
341                 (loop for i upfrom 0
342                       do (format t "~A. count: ~A~%" i (hash-table-count ht))
343                       (force-output)
344                       until (zerop (hash-table-count ht))
345                       do
346                       (when (= i 10)
347                         (print-ht ht)
348                         #-(or x86 x86-64)
349                         (assert nil)
350                         ;; With conservative gc the test may not be
351                         ;; bullet-proof so it's not an outright
352                         ;; failure but a warning.
353                         #+(or x86 x86-64)
354                         (progn
355                           (warn "Weak hash removal test failed for weakness ~A"
356                                 weakness)
357                           (return)))
358                       (gc :full t))))))
359
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))
362         (s "a"))
363     (setf (gethash s ht) s)
364     (assert (eq (gethash s ht) s))
365     (assert (eq (gethash (copy-seq s) ht) s))))
366
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)))
369   (loop repeat 10 do
370         (let ((index (random 2000)))
371           (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
372                 (n 50000))
373             (let ((hash-table (make-hash-table :weakness :key :test 'eq)))
374               (dotimes (i n)
375                 (setf (gethash (+ first i) hash-table) i))
376               hash-table)))))
377
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)))
380   (loop repeat 2 do
381         (let ((h1 (make-hash-table :weakness :key :test #'equal))
382               (keep ()))
383           (loop for i from 0 to 1000
384                 for key = i
385                 for value = (make-array 10000 :fill-pointer 0)
386                 do
387                 (push value keep)
388                 (setf (gethash key h1) value))
389           (sb-ext:gc :full t))))
390
391 )
392
393 ;;; DEFINE-HASH-TABLE-TEST
394
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)))))
415
416
417 (defun head-eql (x y)
418   (every #'eql (subseq x 0 3) (subseq y 0 3)))
419 (define-hash-table-test head-eql
420     (lambda (x)
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)))))
440
441 (with-test (:name :make-hash-table/hash-fun)
442   (let ((table (make-hash-table
443                 :test #'=
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)))))
453
454 ;;; success