tests/clos-interrupts.impure.lisp

   1 ;;; CLOS interrupt safety tests
   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-INTERRUPT-TEST"
  15   (:use "COMMON-LISP" "SB-EXT"))
  16
  17 (in-package "CLOS-INTERRUPT-TEST")
  18
  19 ;;;;; Interrupting applicable method computation and calling the same
  20 ;;;;; GF that was being computed in the interrupt handler must not show
  21 ;;;;; up as metacircle.
  22
  23 ;;; KLUDGE: We just want a way to ensure our interrupt happens at a
  24 ;;; bad place.
  25 ;;;
  26 ;;; FIXME: While an invasive hook like this is probably ok for testing
  27 ;;; purposes, it would also be good to have a proper interrupt-stress
  28 ;;; test for CLOS.
  29 (defmacro define-wrapper (name &key before after)
  30   (let ((real (intern (format nil "*REAL-~A*" name)))
  31         (our (intern (format nil "OUR-~A" name))))
  32     `(progn
  33        (defvar ,real #',name)
  34        (defun ,our (&rest args)
  35          ,@before
  36          (multiple-value-prog1
  37              (apply ,real args)
  38            ,@after))
  39        (without-package-locks
  40          (setf (fdefinition ',name) #',our)))))
  41
  42 (defgeneric compute-test (x y))
  43
  44 (defvar *interrupting* nil)
  45
  46 (defun interrupt ()
  47   (unless *interrupting*
  48     (let ((self sb-thread:*current-thread*)
  49           (*interrupting* t))
  50       ;; Test both interrupting yourself and using another thread
  51       ;; for to interrupting.
  52       #+sb-thread
  53       (progn
  54         (write-line "/interrupt-other")
  55         (sb-thread:join-thread (sb-thread:make-thread
  56                                 (lambda ()
  57                                   (sb-thread:interrupt-thread
  58                                    self
  59                                    (lambda ()
  60                                      (compute-test 1 2)))))))
  61       (write-line "/interrupt-self")
  62       (sb-thread:interrupt-thread self (lambda () (compute-test 1 2))))))
  63
  64 (defvar *interrupted-gfs* nil)
  65
  66 (define-wrapper sb-pcl::compute-applicable-methods-using-types
  67     :before ((when (and (eq (car args) #'compute-test)
  68                         ;; Check that we are at "bad place"
  69                         (assoc (car args) sb-pcl::*cache-miss-values-stack*))
  70                (interrupt)
  71                (pushnew (car args) *interrupted-gfs*))))
  72
  73 (defmethod compute-test (x y)
  74   t)
  75 (defmethod compute-test ((x fixnum) (y fixnum))
  76   'fixnum)
  77 (defmethod compute-test ((x symbol) (y symbol))
  78   'symbol)
  79
  80 (test-util:with-test (:name :compute-test
  81                             :fails-on (and :win32 (not :sb-thread)))
  82   (compute-test 1 2)
  83
  84   ;; Check that we actually interrupted something.
  85   (assert (equal (list #'compute-test) *interrupted-gfs*)))