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:exit :code 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)))