1 ;;;; testing clos cache
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (with-test (:name
:probe-cache-smoke-test
)
15 (let ((caches (sb-vm:list-allocated-objects
:dynamic
16 :test
#'sb-pcl
::cache-p
)))
17 (dolist (cache caches
)
19 (lambda (layouts value
)
20 (multiple-value-bind (foundp found-value
) (sb-pcl::probe-cache cache layouts
)
22 (assert (eq value found-value
))))
25 ;;; The code that CACHE-MIXER-EXPRESSION emits had better compute
26 ;;; the same thing that COMPUTE-CACHE-INDEX does.
27 ;;; (The expression would be wrong if it reduced in the wrong direction, e.g.)
28 (with-test (:name
:compute-index-optimization
)
29 (macrolet ((optimized-way (a b c
)
30 `(let ((a (sb-kernel:layout-clos-hash
,a
))
31 (b (sb-kernel:layout-clos-hash
,b
))
32 (c (sb-kernel:layout-clos-hash
,c
)))
33 ,(sb-pcl::cache-mixer-expression
'sb-int
:mix
'(a b c
) nil
))))
34 (let* ((l1 (sb-kernel:find-layout
'pathname
))
35 (l2 (sb-kernel:find-layout
'cons
))
36 (l3 (sb-kernel:find-layout
'integer
))
37 (cache (sb-pcl::%make-cache
:mask -
1)))
38 (let ((safe-answer (sb-pcl:compute-cache-index cache
(list l1 l2 l3
)))
39 (optimized-answer (optimized-way l1 l2 l3
)))
40 (assert (= safe-answer optimized-answer
)))
41 (let ((safe-answer (sb-pcl:compute-cache-index cache
(list l1 l3 l2
)))
42 (optimized-answer (optimized-way l1 l3 l2
)))
43 (assert (= safe-answer optimized-answer
))))))
45 ;;;; Make a GF, populate it with a ton of methods, and then hammer
46 ;;;; it with multiple threads. On 1.0.6 this would have failed with
47 ;;;; "NIL is not an SB-KERNEL:LAYOUT" pretty quickly.
49 (defgeneric cache-test
(x y
))
51 (defvar *cache-test-classes
* nil
)
55 (defmethod cache-test (x y
)
57 ,@(loop for i from
0 upto
128
59 (let ((c (intern (format nil
"CACHE-TEST-CLASS-~S" i
))))
62 (defmethod cache-test ((x ,c
) (y ,c
))
64 (defmethod cache-test ((x ,c
) y
)
66 (defmethod cache-test (x (y ,c
))
68 (push (find-class ',c
) *cache-test-classes
*)))))))
71 (defvar *run-cache-test
* nil
)
73 (let* ((instances (map 'vector
#'make-instance
*cache-test-classes
*))
74 (limit (length instances
)))
76 (let* ((r (random limit
))
77 (instance (svref instances r
)))
80 (assert (equal (cache-test r r
) '(t t
)))
81 (assert (equal (cache-test r instance
) (list t instance
))))
83 (assert (equal (cache-test instance r
) (list instance t
)))
84 (assert (equal (cache-test instance instance
) (list instance instance
))))))))
86 (let ((lock (sb-thread:make-mutex
)))
87 (defun note (control &rest args
)
88 (let ((string (apply #'format nil control args
)))
89 (sb-thread:with-mutex
(lock)
90 (write-line string
)))))
93 (loop until
*run-cache-test
* do
(sb-thread:thread-yield
))
95 (loop repeat
1024 do
(test-cache))
97 (note "~&Error in cache test in ~S:~%~A~%...aborting"
98 sb-thread
:*current-thread
* e
)
99 (sb-ext:exit
:code
1))))
101 (with-test (:name
:clos-cache-test
102 :broken-on
:sb-safepoint
)
104 (let ((threads (loop repeat
32
105 collect
(sb-thread:make-thread
'test-loop
))))
106 (setf *run-cache-test
* t
)
107 (mapcar #'sb-thread
:join-thread threads
))
111 (setf *run-cache-test
* t
)
115 ;; Check that the test tests what it was supposed to test: the cache.
116 (assert (sb-pcl::cache-p
(sb-pcl::gf-dfun-cache
#'cache-test
))))