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       (write-line "interrupt-1")
  53       (sb-thread:join-thread (sb-thread:make-thread
  54                               (lambda ()
  55                                 (sb-thread:interrupt-thread
  56                                  self
  57                                  (lambda ()
  58                                    (compute-test 1 2))))))
  59       (write-line "interrupt-2")
  60       (sb-thread:interrupt-thread self (lambda () (compute-test 1 2))))))
  61
  62 (defvar *interrupted-gfs* nil)
  63
  64 (define-wrapper sb-pcl::compute-applicable-methods-using-types
  65     :before ((when (and (eq (car args) #'compute-test)
  66                         ;; Check that we are at "bad place"
  67                         (assoc (car args) sb-pcl::*cache-miss-values-stack*))
  68                (interrupt)
  69                (pushnew (car args) *interrupted-gfs*))))
  70
  71 (defmethod compute-test (x y)
  72   t)
  73 (defmethod compute-test ((x fixnum) (y fixnum))
  74   'fixnum)
  75 (defmethod compute-test ((x symbol) (y symbol))
  76   'symbol)
  77
  78 (compute-test 1 2)
  79
  80 ;;; Check that we actually interrupted something.
  81 (assert (equal (list #'compute-test) *interrupted-gfs*))