;;;; testing add/remove-method thread thread safety

  This software is part of the SBCL system . See the README file for
;;;; more information.
;;;;
  While most of SBCL is derived from the CMU CL system , the test
;;;; files (like this one) were written from scratch after the fork
  from CMU CL .
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(defpackage "CLOS-ADD/REMOVE-METHOD"
  (:use "COMMON-LISP" "SB-THREAD"))

(in-package "CLOS-ADD/REMOVE-METHOD")

(defvar *tons-o-method-count* 0)
;; Test for lp#492851
;; On an x86-64 without the fix for garbage retention,
;; this would use up all memory after ~2400 iterations.
;; Now it can run forever, as far as I know.
(defun make-tons-o-methods (&optional (n 50000))
  (dotimes (i n)
    (let ((object (cons "lottajunk" (make-array 20001))))
  FIXME : the first method we defined gets its OBJECT immortalized ,
      ;; because that's the one whose name goes in globaldb
  as the chosen one who arbitrarily created the GF .
      (defmethod blah ((x (eql object))) "what?"
        (when (zerop (mod (incf *tons-o-method-count*) 500))
          (write-char #\.)
          (force-output))
        (if (zerop (mod *tons-o-method-count* 100000))
            (terpri)))
      (funcall 'blah object)) ; late bind to avoid style warning
    (let ((gf (symbol-function 'blah)))
      (remove-method gf (first (sb-mop:generic-function-methods gf))))))

(format t "~&;; Be patient. This test is slow.~%")
(test-util:with-test (:name :exhaust-heap-with-eql-specializers)
  (let ((n-junk 0)
        (starting-eql-spec-count
         (hash-table-count sb-pcl::*eql-specializer-table*)))
    (make-tons-o-methods 50000)
    (sb-int:dx-flet ((visit (object type size)
                       (declare (ignore type size))
                       (when (and (typep object '(cons string (simple-vector 20001)))
                                  (string= (car object) "lottajunk"))
                         (incf n-junk))))
      (sb-vm::map-allocated-objects #'visit :dynamic)
      ;; This is probably not more than a few hundred.
      (format t "~&;; Post-test EQL-spec count: ~S, junk obj count: ~D~%"
              (hash-table-count sb-pcl::*eql-specializer-table*) n-junk)
      (sb-ext:gc :full t)
      (setq n-junk 0)
      (sb-vm::map-allocated-objects #'visit :dynamic)
      (format t "~&;; Post-GC EQL-spec count: ~S, junk obj count: ~D~%"
              (hash-table-count sb-pcl::*eql-specializer-table*) n-junk)
  There should be no stray EQL - specializers left .
  The reasoning is a bit elusive , since the first method 's specializer 's
      ;; OBJECT gets permanentized. But due to the weakness on :VALUE
      ;; in the specializer table, the table entry is dead even though it's
  still possible to get an EQL - specializer for the ( almost ) zombie object .
      ;; But if you do that, you'll get a new specializer, and you can't see
      ;; that it wasn't the previously interned one, unless you do something
  like extend EQL - specializer to have more slots . In that case you could
      ;; sense that your data went missing. But then you probably shouldn't
      ;; be relying on the existing interned specializer table.
  Generic programming is not a panacea .
      (assert (<= (hash-table-count sb-pcl::*eql-specializer-table*)
                  (1+ starting-eql-spec-count))))))

;;; We make a generic function, add a bunch of method for it, and
;;; prepare another bunch of method objects for later addition.
;;;
;;; Then we run several threads in parallel, removing all the old
;;; ones and adding all the new ones -- and finally we verify that
;;; the resulting method set is correct.

(defgeneric foo (x))

(defvar *to-remove-a* nil)
(defvar *to-remove-b* nil)
(defvar *to-remove-c* nil)
(defvar *to-add-d* nil)
(defvar *to-add-e* nil)
(defvar *to-add-f* nil)

(defun name (key n)
  (intern (format nil "FOO-~A-~A" key n)))

(defun names (key)
  (loop for i from 0 upto 128
        collect (name key i)))

(defun to-remove (key)
  (loop for s in (names key)
        collect
        `(progn
           (defclass ,s () ())
           (defmethod foo ((x ,s))
             ',s)
           (push (find-method #'foo nil (list (find-class ',s)) t)
                 ,(intern (format nil "*TO-REMOVE-~A*" key))))))

(defun to-add (key)
  (loop for s in (names key)
        collect
        `(progn
           (defclass ,s () ())
           (push (make-instance
                  'standard-method
                  :qualifiers nil
                  :specializers (list (find-class ',s))
                  :function (lambda (args next)
                              (declare (ignore args next))
                              ',s)
                  :lambda-list '(x))
                 ,(intern (format nil "*TO-ADD-~A*" key))))))

(macrolet ((def ()
             `(progn
                ,@(to-remove 'a)
                ,@(to-remove 'b)
                ,@(to-remove 'c)
                ,@(to-add 'd)
                ,@(to-add 'e)
                ,@(to-add 'f))))
  (def))

(defvar *run* nil)

(defun remove-methods (list)
  (loop until *run* do (sb-thread:thread-yield))
  (dolist (method list)
    (remove-method #'foo method)))

(defun add-methods (list)
  (loop until *run* do (sb-thread:thread-yield))
  (dolist (method list)
    (add-method #'foo method)))

#+sb-thread
(let ((threads (list (make-thread (lambda () (remove-methods *to-remove-a*)))
                     (make-thread (lambda () (remove-methods *to-remove-b*)))
                     (make-thread (lambda () (remove-methods *to-remove-c*)))
                     (make-thread (lambda () (add-methods *to-add-d*)))
                     (make-thread (lambda () (add-methods *to-add-e*)))
                     (make-thread (lambda () (add-methods *to-add-f*))))))
  (setf *run* t)
  (mapcar #'join-thread threads))

#-sb-thread
(progn
  (setf *run* t)
  (remove-methods *to-remove-a*)
  (remove-methods *to-remove-b*)
  (remove-methods *to-remove-c*)
  (add-methods *to-add-d*)
  (add-methods *to-add-e*)
  (add-methods *to-add-f*))

(let ((target (append *to-add-d* *to-add-e* *to-add-f*))
      (real (sb-mop:generic-function-methods #'foo)))
  (assert (subsetp target real))
  (assert (subsetp real target)))

 testing add/remove-method thread thread safety
 more information.

 files (like this one) were written from scratch after the fork

 This software is in the public domain and is provided with
 absolutely no warranty. See the COPYING and CREDITS files for
 more information.
 Test for lp#492851
 On an x86-64 without the fix for garbage retention,
 this would use up all memory after ~2400 iterations.
 Now it can run forever, as far as I know.
 because that's the one whose name goes in globaldb
 late bind to avoid style warning
 This is probably not more than a few hundred.
 OBJECT gets permanentized. But due to the weakness on :VALUE
 in the specializer table, the table entry is dead even though it's
 But if you do that, you'll get a new specializer, and you can't see
 that it wasn't the previously interned one, unless you do something
 sense that your data went missing. But then you probably shouldn't
 be relying on the existing interned specializer table.
 We make a generic function, add a bunch of method for it, and
 prepare another bunch of method objects for later addition.

 Then we run several threads in parallel, removing all the old
 ones and adding all the new ones -- and finally we verify that
 the resulting method set is correct.

  This software is part of the SBCL system . See the README file for
  While most of SBCL is derived from the CMU CL system , the test
  from CMU CL .

(defpackage "CLOS-ADD/REMOVE-METHOD"
  (:use "COMMON-LISP" "SB-THREAD"))

(in-package "CLOS-ADD/REMOVE-METHOD")

(defvar *tons-o-method-count* 0)
(defun make-tons-o-methods (&optional (n 50000))
  (dotimes (i n)
    (let ((object (cons "lottajunk" (make-array 20001))))
  FIXME : the first method we defined gets its OBJECT immortalized ,
  as the chosen one who arbitrarily created the GF .
      (defmethod blah ((x (eql object))) "what?"
        (when (zerop (mod (incf *tons-o-method-count*) 500))
          (write-char #\.)
          (force-output))
        (if (zerop (mod *tons-o-method-count* 100000))
            (terpri)))
    (let ((gf (symbol-function 'blah)))
      (remove-method gf (first (sb-mop:generic-function-methods gf))))))

(format t "~&;; Be patient. This test is slow.~%")
(test-util:with-test (:name :exhaust-heap-with-eql-specializers)
  (let ((n-junk 0)
        (starting-eql-spec-count
         (hash-table-count sb-pcl::*eql-specializer-table*)))
    (make-tons-o-methods 50000)
    (sb-int:dx-flet ((visit (object type size)
                       (declare (ignore type size))
                       (when (and (typep object '(cons string (simple-vector 20001)))
                                  (string= (car object) "lottajunk"))
                         (incf n-junk))))
      (sb-vm::map-allocated-objects #'visit :dynamic)
      (format t "~&;; Post-test EQL-spec count: ~S, junk obj count: ~D~%"
              (hash-table-count sb-pcl::*eql-specializer-table*) n-junk)
      (sb-ext:gc :full t)
      (setq n-junk 0)
      (sb-vm::map-allocated-objects #'visit :dynamic)
      (format t "~&;; Post-GC EQL-spec count: ~S, junk obj count: ~D~%"
              (hash-table-count sb-pcl::*eql-specializer-table*) n-junk)
  There should be no stray EQL - specializers left .
  The reasoning is a bit elusive , since the first method 's specializer 's
  still possible to get an EQL - specializer for the ( almost ) zombie object .
  like extend EQL - specializer to have more slots . In that case you could
  Generic programming is not a panacea .
      (assert (<= (hash-table-count sb-pcl::*eql-specializer-table*)
                  (1+ starting-eql-spec-count))))))


(defgeneric foo (x))

(defvar *to-remove-a* nil)
(defvar *to-remove-b* nil)
(defvar *to-remove-c* nil)
(defvar *to-add-d* nil)
(defvar *to-add-e* nil)
(defvar *to-add-f* nil)

(defun name (key n)
  (intern (format nil "FOO-~A-~A" key n)))

(defun names (key)
  (loop for i from 0 upto 128
        collect (name key i)))

(defun to-remove (key)
  (loop for s in (names key)
        collect
        `(progn
           (defclass ,s () ())
           (defmethod foo ((x ,s))
             ',s)
           (push (find-method #'foo nil (list (find-class ',s)) t)
                 ,(intern (format nil "*TO-REMOVE-~A*" key))))))

(defun to-add (key)
  (loop for s in (names key)
        collect
        `(progn
           (defclass ,s () ())
           (push (make-instance
                  'standard-method
                  :qualifiers nil
                  :specializers (list (find-class ',s))
                  :function (lambda (args next)
                              (declare (ignore args next))
                              ',s)
                  :lambda-list '(x))
                 ,(intern (format nil "*TO-ADD-~A*" key))))))

(macrolet ((def ()
             `(progn
                ,@(to-remove 'a)
                ,@(to-remove 'b)
                ,@(to-remove 'c)
                ,@(to-add 'd)
                ,@(to-add 'e)
                ,@(to-add 'f))))
  (def))

(defvar *run* nil)

(defun remove-methods (list)
  (loop until *run* do (sb-thread:thread-yield))
  (dolist (method list)
    (remove-method #'foo method)))

(defun add-methods (list)
  (loop until *run* do (sb-thread:thread-yield))
  (dolist (method list)
    (add-method #'foo method)))

#+sb-thread
(let ((threads (list (make-thread (lambda () (remove-methods *to-remove-a*)))
                     (make-thread (lambda () (remove-methods *to-remove-b*)))
                     (make-thread (lambda () (remove-methods *to-remove-c*)))
                     (make-thread (lambda () (add-methods *to-add-d*)))
                     (make-thread (lambda () (add-methods *to-add-e*)))
                     (make-thread (lambda () (add-methods *to-add-f*))))))
  (setf *run* t)
  (mapcar #'join-thread threads))

#-sb-thread
(progn
  (setf *run* t)
  (remove-methods *to-remove-a*)
  (remove-methods *to-remove-b*)
  (remove-methods *to-remove-c*)
  (add-methods *to-add-d*)
  (add-methods *to-add-e*)
  (add-methods *to-add-f*))

(let ((target (append *to-add-d* *to-add-e* *to-add-f*))
      (real (sb-mop:generic-function-methods #'foo)))
  (assert (subsetp target real))
  (assert (subsetp real target)))
