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 (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)
  18       (sb-pcl::map-cache
  19        (lambda (layouts value)
  20          (multiple-value-bind (foundp found-value) (sb-pcl::probe-cache cache layouts)
  21            (assert foundp)
  22            (assert (eq value found-value))))
  23        cache))))
  24
  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))))))
  44
  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.
  48
  49 (defgeneric cache-test (x y))
  50
  51 (defvar *cache-test-classes* nil)
  52
  53 (macrolet ((def ()
  54              `(progn
  55                 (defmethod cache-test (x y)
  56                   (list t t))
  57                 ,@(loop for i from 0 upto 128
  58                        collect
  59                         (let ((c (intern (format nil "CACHE-TEST-CLASS-~S" i))))
  60                           `(progn
  61                              (defclass ,c () ())
  62                              (defmethod cache-test ((x ,c) (y ,c))
  63                                (list x y))
  64                              (defmethod cache-test ((x ,c) y)
  65                                (list x t))
  66                              (defmethod cache-test (x (y ,c))
  67                                (list t y))
  68                              (push (find-class ',c) *cache-test-classes*)))))))
  69   (def))
  70
  71 (defvar *run-cache-test* nil)
  72
  73 (let* ((instances (map 'vector #'make-instance *cache-test-classes*))
  74        (limit (length instances)))
  75   (defun test-cache ()
  76     (let* ((r (random limit))
  77            (instance (svref instances r)))
  78       (if (logbitp 0 r)
  79           (if (logbitp 1 r)
  80               (assert (equal (cache-test r r) '(t t)))
  81               (assert (equal (cache-test r instance) (list t instance))))
  82           (if (logbitp 1 r)
  83               (assert (equal (cache-test instance r) (list instance t)))
  84               (assert (equal (cache-test instance instance) (list instance instance))))))))
  85
  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)))))
  91
  92 (defun test-loop ()
  93   (loop until *run-cache-test* do (sb-thread:thread-yield))
  94   (handler-case
  95       (loop repeat 1024 do (test-cache))
  96     (error (e)
  97       (note "~&Error in cache test in ~S:~%~A~%...aborting"
  98             sb-thread:*current-thread* e)
  99       (sb-ext:exit :code 1))))
 100
 101 (with-test (:name :clos-cache-test
 102             :broken-on :sb-safepoint)
 103   #+sb-thread
 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))
 108
 109   #-sb-thread
 110   (progn
 111     (setf *run-cache-test* t)
 112     (loop repeat 4
 113           do (test-loop)))
 114
 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))))