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