1 ;;;; gray-box testing of the constructor optimization machinery
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 (load "test-util.lisp")
16 (defpackage "CTOR-TEST"
17 (:use
"CL" "TEST-UTIL"))
19 (in-package "CTOR-TEST")
21 (defclass no-slots
() ())
23 (defun make-no-slots ()
24 (make-instance 'no-slots
))
25 (compile 'make-no-slots
)
27 (defmethod update-instance-for-redefined-class
28 ((object no-slots
) added discarded plist
&rest initargs
)
29 (declare (ignore initargs
))
30 (error "Called U-I-F-R-C on ~A" object
))
32 (assert (typep (make-no-slots) 'no-slots
))
34 (make-instances-obsolete 'no-slots
)
36 (assert (typep (make-no-slots) 'no-slots
))
37 (assert (typep (funcall #'(sb-pcl::ctor no-slots nil
)) 'no-slots
))
42 (defun make-one-slot-a (a)
43 (make-instance 'one-slot
:a a
))
44 (compile 'make-one-slot-a
)
45 (defun make-one-slot-noa ()
46 (make-instance 'one-slot
))
47 (compile 'make-one-slot-noa
)
49 (defmethod update-instance-for-redefined-class
50 ((object one-slot
) added discarded plist
&rest initargs
)
51 (declare (ignore initargs
))
52 (error "Called U-I-F-R-C on ~A" object
))
54 (assert (= (slot-value (make-one-slot-a 3) 'a
) 3))
55 (assert (not (slot-boundp (make-one-slot-noa) 'a
)))
57 (make-instances-obsolete 'one-slot
)
59 (assert (= (slot-value (make-one-slot-a 3) 'a
) 3))
60 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot nil
:a sb-pcl
::\.p0.
) 4) 'a
) 4))
61 (assert (not (slot-boundp (make-one-slot-noa) 'a
)))
62 (assert (not (slot-boundp (funcall #'(sb-pcl::ctor one-slot nil
)) 'a
)))
64 (defclass one-slot-superclass
()
66 (defclass one-slot-subclass
(one-slot-superclass)
69 (defun make-one-slot-subclass (b)
70 (make-instance 'one-slot-subclass
:b b
))
71 (compile 'make-one-slot-subclass
)
73 (defmethod update-instance-for-redefined-class
74 ((object one-slot-superclass
) added discarded plist
&rest initargs
)
75 (declare (ignore initargs
))
76 (error "Called U-I-F-R-C on ~A" object
))
78 (assert (= (slot-value (make-one-slot-subclass 2) 'b
) 2))
80 (make-instances-obsolete 'one-slot-subclass
)
82 (assert (= (slot-value (make-one-slot-subclass 2) 'b
) 2))
83 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil
:b sb-pcl
::\.p0.
) 3) 'b
) 3))
84 (make-instances-obsolete 'one-slot-superclass
)
86 (assert (= (slot-value (make-one-slot-subclass 2) 'b
) 2))
87 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil
:b sb-pcl
::\.p0.
) 4) 'b
) 4))
89 ;;; Tests for CTOR optimization of non-constant class args and constant class object args
90 (defun find-ctor-cache (f)
91 (let ((code (sb-kernel:fun-code-header f
)))
92 (loop for i from sb-vm
::code-constants-offset below
(sb-kernel:get-header-data code
)
93 for c
= (sb-kernel:code-header-ref code i
)
94 do
(when (= sb-vm
::value-cell-header-widetag
(sb-kernel:widetag-of c
))
95 (let ((c (sb-vm::value-cell-ref c
)))
96 (when (and (consp c
) (eq 'sb-pcl
::ctor-cache
(car c
)))
99 ;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this
101 (defun find-callee (f &key
(type t
) (name nil namep
))
102 (let ((code (sb-kernel:fun-code-header
(sb-kernel:%fun-fun f
))))
103 (loop for i from sb-vm
::code-constants-offset below
(sb-kernel:get-header-data code
)
104 for c
= (sb-kernel:code-header-ref code i
)
105 do
(when (typep c
'sb-impl
::fdefn
)
106 (let ((fun (sb-impl::fdefn-fun c
)))
107 (when (and (typep fun type
)
109 (equal name
(sb-impl::fdefn-name c
))))
112 (let* ((cmacro (compiler-macro-function 'make-instance
))
114 (wrapper (lambda (form env
)
115 (let ((res (funcall cmacro form env
)))
116 (unless (eq form res
)
119 (sb-ext:without-package-locks
122 (setf (compiler-macro-function 'make-instance
) wrapper
)
123 (with-test (:name
(make-instance :non-constant-class
))
125 (let ((f (compile nil
`(lambda (class)
126 (make-instance class
:b t
)))))
127 (assert (find-ctor-cache f
))
129 (assert (typep (funcall f
'one-slot-subclass
) 'one-slot-subclass
))))
130 (with-test (:name
(make-instance :constant-class-object
))
131 (let ((f (compile nil
`(lambda ()
132 (make-instance ,(find-class 'one-slot-subclass
) :b t
)))))
133 (assert (not (find-ctor-cache f
)))
135 (assert (typep (funcall f
) 'one-slot-subclass
))))
136 (with-test (:name
(make-instance :constant-non-std-class-object
))
137 (let ((f (compile nil
`(lambda ()
138 (make-instance ,(find-class 'structure-object
))))))
139 (assert (not (find-ctor-cache f
)))
141 (assert (typep (funcall f
) 'structure-object
))))
142 (with-test (:name
(make-instance :constant-non-std-class-name
))
143 (let ((f (compile nil
`(lambda ()
144 (make-instance 'structure-object
)))))
145 (assert (not (find-ctor-cache f
)))
147 (assert (typep (funcall f
) 'structure-object
)))))
148 (setf (compiler-macro-function 'make-instance
) cmacro
))))
150 (with-test (:name
(make-instance :ctor-inline-cache-resize
))
151 (let* ((f (compile nil
`(lambda (name) (make-instance name
))))
152 (classes (loop repeat
(* 2 sb-pcl
::+ctor-table-max-size
+)
153 collect
(class-name (eval `(defclass ,(gentemp) () ())))))
155 (cache (find-ctor-cache f
)))
157 (assert (not (cdr cache
)))
158 (dolist (class classes
)
159 (assert (typep (funcall f
(if (oddp count
) class
(find-class class
))) class
))
161 (cond ((<= count sb-pcl
::+ctor-list-max-size
+)
162 (unless (consp (cdr cache
))
163 (error "oops, wanted list cache, got: ~S" cache
))
164 (unless (= count
(length (cdr cache
)))
165 (error "oops, wanted ~S elts in cache, got: ~S" count cache
)))
167 (assert (simple-vector-p (cdr cache
))))))
168 (dolist (class classes
)
169 (assert (typep (funcall f
(if (oddp count
) class
(find-class class
))) class
))
172 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
173 (defclass some-class
()
174 ((aroundp :initform nil
:reader aroundp
))
175 (:default-initargs
:x
:success1
))
177 (defmethod initialize-instance :around
((some-class some-class
) &key
(x :fail?
))
178 (unless (eq x
:success1
)
179 (error "Default initarg lossage"))
180 (setf (slot-value some-class
'aroundp
) t
)
181 (when (next-method-p)
184 (with-test (:name
(make-instance :ctor-default-initargs-1
))
185 (assert (aroundp (eval `(make-instance 'some-class
))))
186 (let ((fun (compile nil
`(lambda () (make-instance 'some-class
)))))
187 (assert (aroundp (funcall fun
)))
188 ;; make sure we tested what we think we tested...
189 (let ((ctor (find-callee fun
:type
'sb-pcl
::ctor
)))
190 (assert (find-callee ctor
:name
'sb-pcl
::fast-make-instance
)))))
192 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
193 ;;; in more interesting cases as well...
194 (defparameter *some-counter
* 0)
195 (let* ((x 'success2
))
196 (defclass some-class2
()
197 ((aroundp :initform nil
:reader aroundp
))
198 (:default-initargs
:x
(progn (incf *some-counter
*) x
))))
200 (defmethod initialize-instance :around
((some-class some-class2
) &key
(x :fail2?
))
201 (unless (eq x
'success2
)
202 (error "Default initarg lossage"))
203 (setf (slot-value some-class
'aroundp
) t
)
204 (when (next-method-p)
207 (with-test (:name
(make-instance :ctor-default-initargs-2
))
208 (assert (= 0 *some-counter
*))
209 (assert (aroundp (eval `(make-instance 'some-class2
))))
210 (assert (= 1 *some-counter
*))
211 (let ((fun (compile nil
`(lambda () (make-instance 'some-class2
)))))
212 (assert (= 1 *some-counter
*))
213 (assert (aroundp (funcall fun
)))
214 (assert (= 2 *some-counter
*))
215 ;; make sure we tested what we think we tested...
216 (let ((ctor (find-callee fun
:type
'sb-pcl
::ctor
)))
217 (assert (find-callee ctor
:name
'sb-pcl
::fast-make-instance
)))))
219 ;;; No compiler notes, please
220 (locally (declare (optimize safety
))
221 (defclass type-check-thing
()
222 ((slot :type
(integer 0) :initarg
:slot
))))
223 (with-test (:name
(make-instance :no-compile-note-at-runtime
))
224 (let ((fun (compile nil
`(lambda (x)
225 (declare (optimize safety
))
226 (make-instance 'type-check-thing
:slot x
)))))
227 (handler-bind ((sb-ext:compiler-note
#'error
))