1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / clos-cache.impure.lisp
1 ;;;; testing clos cache
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (defpackage "CLOS-CACHE-TEST"
15   (:use "COMMON-LISP"))
16
17 (in-package "CLOS-CACHE-TEST")
18
19 ;;;; Make a GF, populate it with a ton of methods, and then hammer
20 ;;;; it with multiple threads. On 1.0.6 this would have failed with
21 ;;;; "NIL is not an SB-KERNEL:LAYOUT" pretty quickly.
22
23 (defgeneric cache-test (x y))
24
25 (defvar *cache-test-classes* nil)
26
27 (macrolet ((def ()
28              `(progn
29                 (defmethod cache-test (x y)
30                   (list t t))
31                 ,@(loop for i from 0 upto 128
32                        collect
33                         (let ((c (intern (format nil "CACHE-TEST-CLASS-~S" i))))
34                           `(progn
35                              (defclass ,c () ())
36                              (defmethod cache-test ((x ,c) (y ,c))
37                                (list x y))
38                              (defmethod cache-test ((x ,c) y)
39                                (list x t))
40                              (defmethod cache-test (x (y ,c))
41                                (list t y))
42                              (push (find-class ',c) *cache-test-classes*)))))))
43   (def))
44
45 (defvar *run-cache-test* nil)
46
47 (let* ((instances (map 'vector #'make-instance *cache-test-classes*))
48        (limit (length instances)))
49   (defun test-cache ()
50     (let* ((r (random limit))
51            (instance (svref instances r)))
52       (if (logbitp 0 r)
53           (if (logbitp 1 r)
54               (assert (equal (cache-test r r) '(t t)))
55               (assert (equal (cache-test r instance) (list t instance))))
56           (if (logbitp 1 r)
57               (assert (equal (cache-test instance r) (list instance t)))
58               (assert (equal (cache-test instance instance) (list instance instance))))))))
59
60 (let ((lock (sb-thread:make-mutex)))
61   (defun note (control &rest args)
62     (let ((string (apply #'format nil control args)))
63       (sb-thread:with-mutex (lock)
64         (write-line string)))))
65
66 (defun test-loop ()
67   (note "/~S waiting for permission to run" sb-thread:*current-thread*)
68   (loop until *run-cache-test* do (sb-thread:thread-yield))
69   (note "/~S joining the thundering herd" sb-thread:*current-thread*)
70   (handler-case
71       (loop repeat 1024 do (test-cache))
72     (error (e)
73       (note "~&Error in cache test in ~S:~%~A~%...aborting"
74             sb-thread:*current-thread* e)
75       (sb-ext:quit :unix-status 1)))
76   (note "/~S done" sb-thread:*current-thread*))
77
78 #+sb-thread
79 (let ((threads (loop repeat 32
80                      collect (sb-thread:make-thread 'test-loop))))
81   (setf *run-cache-test* t)
82   (mapcar #'sb-thread:join-thread threads))
83
84 #-sb-thread
85 (progn
86   (setf *run-cache-test* t)
87   (loop repeat 4
88         do (test-loop)))
89
90 ;;; Check that the test tests what it was supposed to test: the cache.
91 (assert (sb-pcl::cache-p (sb-pcl::gf-dfun-cache #'cache-test)))