tests/clos-add-remove-method.impure.lisp

   1 ;;;; testing add/remove-method thread thread safety
   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-ADD/REMOVE-METHOD"
  15   (:use "COMMON-LISP" "SB-THREAD"))
  16
  17 (in-package "CLOS-ADD/REMOVE-METHOD")
  18
  19 ;;; We make a generic function, add a bunch of method for it, and
  20 ;;; prepare another bunch of method objects for later addition.
  21 ;;;
  22 ;;; Then we run several threads in parallel, removing all the old
  23 ;;; ones and adding all the new ones -- and finally we verify that
  24 ;;; the resulting method set is correct.
  25
  26 (defgeneric foo (x))
  27
  28 (defvar *to-remove-a* nil)
  29 (defvar *to-remove-b* nil)
  30 (defvar *to-remove-c* nil)
  31 (defvar *to-add-d* nil)
  32 (defvar *to-add-e* nil)
  33 (defvar *to-add-f* nil)
  34
  35 (defun name (key n)
  36   (intern (format nil "FOO-~A-~A" key n)))
  37
  38 (defun names (key)
  39   (loop for i from 0 upto 128
  40         collect (name key i)))
  41
  42 (defun to-remove (key)
  43   (loop for s in (names key)
  44         collect
  45         `(progn
  46            (defclass ,s () ())
  47            (defmethod foo ((x ,s))
  48              ',s)
  49            (push (find-method #'foo nil (list (find-class ',s)) t)
  50                  ,(intern (format nil "*TO-REMOVE-~A*" key))))))
  51
  52 (defun to-add (key)
  53   (loop for s in (names key)
  54         collect
  55         `(progn
  56            (defclass ,s () ())
  57            (push (make-instance
  58                   'standard-method
  59                   :qualifiers nil
  60                   :specializers (list (find-class ',s))
  61                   :function (lambda (args next)
  62                               (declare (ignore args next))
  63                               ',s)
  64                   :lambda-list '(x))
  65                  ,(intern (format nil "*TO-ADD-~A*" key))))))
  66
  67 (macrolet ((def ()
  68              `(progn
  69                 ,@(to-remove 'a)
  70                 ,@(to-remove 'b)
  71                 ,@(to-remove 'c)
  72                 ,@(to-add 'd)
  73                 ,@(to-add 'e)
  74                 ,@(to-add 'f))))
  75   (def))
  76
  77 (defvar *run* nil)
  78
  79 (defun remove-methods (list)
  80   (loop until *run* do (sb-thread:thread-yield))
  81   (dolist (method list)
  82     (remove-method #'foo method)))
  83
  84 (defun add-methods (list)
  85   (loop until *run* do (sb-thread:thread-yield))
  86   (dolist (method list)
  87     (add-method #'foo method)))
  88
  89 #+sb-thread
  90 (let ((threads (list (make-thread (lambda () (remove-methods *to-remove-a*)))
  91                      (make-thread (lambda () (remove-methods *to-remove-b*)))
  92                      (make-thread (lambda () (remove-methods *to-remove-c*)))
  93                      (make-thread (lambda () (add-methods *to-add-d*)))
  94                      (make-thread (lambda () (add-methods *to-add-e*)))
  95                      (make-thread (lambda () (add-methods *to-add-f*))))))
  96   (setf *run* t)
  97   (mapcar #'join-thread threads))
  98
  99 #-sb-thread
 100 (progn
 101   (setf *run* t)
 102   (remove-methods *to-remove-a*)
 103   (remove-methods *to-remove-b*)
 104   (remove-methods *to-remove-c*)
 105   (add-methods *to-add-d*)
 106   (add-methods *to-add-e*)
 107   (add-methods *to-add-f*))
 108
 109 (let ((target (append *to-add-d* *to-add-e* *to-add-f*))
 110       (real (sb-mop:generic-function-methods #'foo)))
 111   (assert (subsetp target real))
 112   (assert (subsetp real target)))