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