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 ((layout
  16          (sb-kernel::make-layout :clos-hash #xAd00d
  17                                  :classoid (sb-kernel::make-undefined-classoid 'x)))
  18         (cache (sb-pcl::make-cache :key-count 1 :value t :size 10)))
  19     (sb-pcl::try-update-cache cache (list layout) 'win)
  20     (assert (eq (nth-value 1 (sb-pcl::probe-cache cache (list layout))) 'win))
  21     (assert (eq (nth-value 1 (sb-pcl::probe-cache cache layout)) 'win))))
  22
  23 ;;;; Make a GF, populate it with a ton of methods, and then hammer
  24 ;;;; it with multiple threads. On 1.0.6 this would have failed with
  25 ;;;; "NIL is not an SB-KERNEL:LAYOUT" pretty quickly.
  26
  27 (defgeneric cache-test (x y))
  28
  29 (defvar *cache-test-classes* nil)
  30
  31 (macrolet ((def ()
  32              `(progn
  33                 (defmethod cache-test (x y)
  34                   (list t t))
  35                 ,@(loop for i from 0 upto 128
  36                        collect
  37                         (let ((c (intern (format nil "CACHE-TEST-CLASS-~S" i))))
  38                           `(progn
  39                              (defclass ,c () ())
  40                              (defmethod cache-test ((x ,c) (y ,c))
  41                                (list x y))
  42                              (defmethod cache-test ((x ,c) y)
  43                                (list x t))
  44                              (defmethod cache-test (x (y ,c))
  45                                (list t y))
  46                              (push (find-class ',c) *cache-test-classes*)))))))
  47   (def))
  48
  49 (defvar *run-cache-test* nil)
  50
  51 (let* ((instances (map 'vector #'make-instance *cache-test-classes*))
  52        (limit (length instances)))
  53   (defun test-cache ()
  54     (let* ((r (random limit))
  55            (instance (svref instances r)))
  56       (if (logbitp 0 r)
  57           (if (logbitp 1 r)
  58               (assert (equal (cache-test r r) '(t t)))
  59               (assert (equal (cache-test r instance) (list t instance))))
  60           (if (logbitp 1 r)
  61               (assert (equal (cache-test instance r) (list instance t)))
  62               (assert (equal (cache-test instance instance) (list instance instance))))))))
  63
  64 (let ((lock (sb-thread:make-mutex)))
  65   (defun note (control &rest args)
  66     (let ((string (apply #'format nil control args)))
  67       (sb-thread:with-mutex (lock)
  68         (write-line string)))))
  69
  70 (defun test-loop ()
  71   (note "/~S waiting for permission to run" sb-thread:*current-thread*)
  72   (loop until *run-cache-test* do (sb-thread:thread-yield))
  73   (note "/~S joining the thundering herd" sb-thread:*current-thread*)
  74   (handler-case
  75       (loop repeat 1024 do (test-cache))
  76     (error (e)
  77       (note "~&Error in cache test in ~S:~%~A~%...aborting"
  78             sb-thread:*current-thread* e)
  79       (sb-ext:exit :code 1)))
  80   (note "/~S done" sb-thread:*current-thread*))
  81
  82 (with-test (:name :clos-cache-test
  83             :broken-on :sb-safepoint)
  84   #+sb-thread
  85   (let ((threads (loop repeat 32
  86                        collect (sb-thread:make-thread 'test-loop))))
  87     (setf *run-cache-test* t)
  88     (mapcar #'sb-thread:join-thread threads))
  89
  90   #-sb-thread
  91   (progn
  92     (setf *run-cache-test* t)
  93     (loop repeat 4
  94           do (test-loop)))
  95
  96   ;; Check that the test tests what it was supposed to test: the cache.
  97   (assert (sb-pcl::cache-p (sb-pcl::gf-dfun-cache #'cache-test))))