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 "compiler-test-util.lisp")
16 (defpackage "CTOR-TEST"
17 (:use
"CL" "TEST-UTIL" "COMPILER-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 (gethash '(sb-pcl::ctor no-slots nil
) sb-pcl
::*all-ctors
*)) '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 (gethash '(sb-pcl::ctor one-slot nil
:a sb-pcl
::\.p0.
) sb-pcl
::*all-ctors
*)
62 (assert (not (slot-boundp (make-one-slot-noa) 'a
)))
63 (assert (not (slot-boundp (funcall (gethash '(sb-pcl::ctor one-slot nil
) sb-pcl
::*all-ctors
*)) 'a
)))
65 (defclass one-slot-superclass
()
67 (defclass one-slot-subclass
(one-slot-superclass)
70 (defun make-one-slot-subclass (b)
71 (make-instance 'one-slot-subclass
:b b
))
72 (compile 'make-one-slot-subclass
)
74 (defmethod update-instance-for-redefined-class
75 ((object one-slot-superclass
) added discarded plist
&rest initargs
)
76 (declare (ignore initargs
))
77 (error "Called U-I-F-R-C on ~A" object
))
79 (assert (= (slot-value (make-one-slot-subclass 2) 'b
) 2))
81 (make-instances-obsolete 'one-slot-subclass
)
83 (assert (= (slot-value (make-one-slot-subclass 2) 'b
) 2))
84 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot-subclass nil
:b sb-pcl
::\.p0.
) sb-pcl
::*all-ctors
*)
86 (make-instances-obsolete 'one-slot-superclass
)
88 (assert (= (slot-value (make-one-slot-subclass 2) 'b
) 2))
89 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot-subclass nil
:b sb-pcl
::\.p0.
) sb-pcl
::*all-ctors
*)
92 ;;; Tests for CTOR optimization of non-constant class args and constant class object args
93 (defun find-ctor-caches (fun)
94 (remove-if-not (lambda (value)
95 (and (consp value
) (eq 'sb-pcl
::ctor-cache
(car value
))))
96 (find-code-constants fun
)))
98 (let* ((transform (sb-int:info
:function
:source-transform
'make-instance
))
100 (wrapper (lambda (form env
)
101 (let ((res (funcall transform form env
)))
102 (unless (eq form res
)
105 (sb-ext:without-package-locks
108 (setf (sb-int:info
:function
:source-transform
'make-instance
) wrapper
)
109 (with-test (:name
(make-instance :non-constant-class
))
111 (let ((f (checked-compile `(lambda (class)
112 (make-instance class
:b t
)))))
113 (assert (= 1 (length (find-ctor-caches f
))))
115 (assert (typep (funcall f
'one-slot-subclass
) 'one-slot-subclass
))))
116 (with-test (:name
(make-instance :constant-class-object
))
117 (let ((f (checked-compile `(lambda ()
118 (make-instance ,(find-class 'one-slot-subclass
) :b t
)))))
119 (assert (not (find-ctor-caches f
)))
121 (assert (typep (funcall f
) 'one-slot-subclass
))))
122 (with-test (:name
(make-instance :constant-non-std-class-object
))
123 (let ((f (checked-compile `(lambda ()
124 (make-instance ,(find-class 'structure-object
))))))
125 (assert (not (find-ctor-caches f
)))
127 (assert (typep (funcall f
) 'structure-object
))))
128 (with-test (:name
(make-instance :constant-non-std-class-name
))
129 (let ((f (checked-compile `(lambda ()
130 (make-instance 'structure-object
)))))
131 (assert (not (find-ctor-caches f
)))
133 (assert (typep (funcall f
) 'structure-object
)))))
134 (setf (sb-int:info
:function
:source-transform
'make-instance
) transform
))))
136 (with-test (:name
(make-instance :ctor-inline-cache-resize
))
137 (let* ((f (checked-compile `(lambda (name) (make-instance name
))))
138 (classes (loop repeat
(* 2 sb-pcl
:+ctor-table-max-size
+)
139 collect
(class-name (eval `(defclass ,(gentemp) () ())))))
141 (caches (find-ctor-caches f
))
142 (cache (pop caches
)))
144 (assert (not caches
))
145 (assert (not (cdr cache
)))
146 (dolist (class classes
)
147 (assert (typep (funcall f
(if (oddp count
) class
(find-class class
))) class
))
149 (cond ((<= count sb-pcl
:+ctor-list-max-size
+)
150 (unless (consp (cdr cache
))
151 (error "oops, wanted list cache, got: ~S" cache
))
152 (unless (= count
(length (cdr cache
)))
153 (error "oops, wanted ~S elts in cache, got: ~S" count cache
)))
155 (assert (simple-vector-p (cdr cache
))))))
156 (dolist (class classes
)
157 (assert (typep (funcall f
(if (oddp count
) class
(find-class class
))) class
))
160 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
161 (defclass some-class
()
162 ((aroundp :initform nil
:reader aroundp
))
163 (:default-initargs
:x
:success1
))
165 (defmethod shared-initialize :around
((some-class some-class
) slots
&key
(x :fail?
))
166 (unless (eq x
:success1
)
167 (error "Default initarg lossage"))
168 (setf (slot-value some-class
'aroundp
) t
)
169 (when (next-method-p)
172 (with-test (:name
(make-instance :ctor-default-initargs-1
))
173 (assert (aroundp (eval `(make-instance 'some-class
))))
174 (let ((fun (checked-compile `(lambda () (make-instance 'some-class
)))))
175 (assert (aroundp (funcall fun
)))
176 ;; make sure we tested what we think we tested...
177 (let ((ctors (find-anonymous-callees fun
:type
'sb-pcl
::ctor
)))
179 (assert (not (cdr ctors
)))
180 (assert (asm-search "FAST-MAKE-INSTANCE" (car ctors
))))))
182 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
183 ;;; in more interesting cases as well...
184 (defparameter *some-counter
* 0)
185 (let* ((x 'success2
))
186 (defclass some-class2
()
187 ((aroundp :initform nil
:reader aroundp
))
188 (:default-initargs
:x
(progn (incf *some-counter
*) x
))))
190 (defmethod shared-initialize :around
((some-class some-class2
) slots
&key
(x :fail2?
))
191 (unless (eq x
'success2
)
192 (error "Default initarg lossage"))
193 (setf (slot-value some-class
'aroundp
) t
)
194 (when (next-method-p)
197 (with-test (:name
(make-instance :ctor-default-initargs-2
))
198 (assert (= 0 *some-counter
*))
199 (assert (aroundp (eval `(make-instance 'some-class2
))))
200 (assert (= 1 *some-counter
*))
201 (let ((fun (checked-compile `(lambda () (make-instance 'some-class2
)))))
202 (assert (= 1 *some-counter
*))
203 (assert (aroundp (funcall fun
)))
204 (assert (= 2 *some-counter
*))
205 ;; make sure we tested what we think we tested...
206 (let ((ctors (find-anonymous-callees fun
:type
'sb-pcl
::ctor
)))
208 (assert (not (cdr ctors
)))
209 (assert (asm-search "FAST-MAKE-INSTANCE" (car ctors
))))))
211 ;;; No compiler notes, please
212 (locally (declare (optimize safety
))
213 (defclass type-check-thing
()
214 ((slot :type
(integer 0) :initarg
:slot
))))
215 (with-test (:name
(make-instance :no-compile-note-at-runtime
))
216 (let ((fun (checked-compile `(lambda (x)
217 (declare (optimize safety
))
218 (make-instance 'type-check-thing
:slot x
)))))
219 (handler-bind ((sb-ext:compiler-note
#'error
))
223 ;;; NO-APPLICABLE-METHOD called
224 (defmethod no-applicable-method ((gf (eql #'make-instance
)) &rest args
)
225 (cons :no-applicable-method args
))
226 (with-test (:name
:constant-invalid-class-arg
)
227 (checked-compile-and-assert ()
228 `(lambda (x) (make-instance "FOO" :quux x
))
229 ((14) '(:no-applicable-method
"FOO" :quux
14)))
230 (checked-compile-and-assert ()
231 `(lambda (x y
) (make-instance ''abc
'zot x
'bar y
))
232 ((1 2) '(:no-applicable-method
'abc zot
1 bar
2))))
234 (with-test (:name
:variable-invalid-class-arg
)
235 (checked-compile-and-assert ()
236 `(lambda (c x
) (make-instance c
:quux x
))
237 (("FOO" 14) '(:no-applicable-method
"FOO" :quux
14)))
238 (checked-compile-and-assert ()
239 `(lambda (c x y
) (make-instance c
'zot x
'bar y
))
240 ((''abc
1 2) '(:no-applicable-method
'abc zot
1 bar
2))))
242 (defclass sneaky-class
(standard-class)
245 (defmethod sb-mop:validate-superclass
((class sneaky-class
) (super standard-class
))
249 ((dirty :initform nil
:accessor dirty-slots
)
250 (a :initarg
:a
:reader sneaky-a
)
251 (b :initform
"b" :reader sneaky-b
)
252 (c :accessor sneaky-c
))
253 (:metaclass sneaky-class
))
255 (defvar *supervising
* nil
)
257 (defmethod (setf sb-mop
:slot-value-using-class
)
258 :before
(value (class sneaky-class
) (instance sneaky
) slotd
)
259 (unless *supervising
*
260 (let ((name (sb-mop:slot-definition-name slotd
))
262 (when (slot-boundp instance
'dirty
)
263 (pushnew name
(dirty-slots instance
))))))
265 (with-test (:name
(make-instance :setf-slot-value-using-class-hits-other-slots
))
266 (let ((fun (checked-compile `(lambda (a c
)
267 (let ((i (make-instance 'sneaky
:a a
)))
268 (setf (sneaky-c i
) c
)
271 do
(let ((i (funcall fun
"a" "c")))
272 (assert (equal '(c b a
) (dirty-slots i
)))
273 (assert (equal "a" (sneaky-a i
)))
274 (assert (equal "b" (sneaky-b i
)))
275 (assert (equal "c" (sneaky-c i
)))))))
277 (defclass bug-728650-base
()
282 (defmethod initialize-instance :after
((instance bug-728650-base
) &key
)
283 (with-slots (value) instance
285 (error "Impossible! Value slot not initialized in ~S" instance
))))
287 (defclass bug-728650-child-1
(bug-728650-base)
290 (defmethod initialize-instance :around
((instance bug-728650-child-1
) &rest initargs
&key
)
291 (apply #'call-next-method instance
:value
'provided-by-child-1 initargs
))
293 (defclass bug-728650-child-2
(bug-728650-base)
296 (defmethod initialize-instance :around
((instance bug-728650-child-2
) &rest initargs
&key
)
297 (let ((foo (make-instance 'bug-728650-child-1
)))
298 (apply #'call-next-method instance
:value foo initargs
)))
300 (with-test (:name
:bug-728650
)
301 (let ((child1 (slot-value (make-instance 'bug-728650-child-2
) 'value
)))
302 (assert (typep child1
'bug-728650-child-1
))
303 (assert (eq 'provided-by-child-1
(slot-value child1
'value
)))))
305 (defclass test-fancy-cnm
() ((a :initarg
:a
)))
306 (defmethod initialize-instance :around
((self test-fancy-cnm
) &rest args
)
307 ;; WALK-METHOD-LAMBDA would get to the second form of CALL-NEXT-METHOD
308 ;; and set the CALL-NEXT-METHOD-P flag to :SIMPLE
309 ;; even though it had already been set to T by the earlier call.
311 (call-next-method self
:a
`(expect-this ,(getf args
:a
)))
313 (defun fancy-cnm-in-ii-test (x) (make-instance 'test-fancy-cnm
:a x
))
314 (with-test (:name
:bug-1397454
)
315 (assert (equal (slot-value (fancy-cnm-in-ii-test 'hi
) 'a
)
318 (with-test (:name
(make-instance :ctor
319 :constant-initarg
:constant-redefinition
321 (let ((class-name (gensym))
324 (eval `(defclass ,class-name
() ((,slot-name
:initarg
:s
325 :reader
,slot-name
))))
326 (flet ((define-constant (name value
)
327 (handler-bind ((sb-ext:defconstant-uneql
#'continue
))
328 (eval `(defconstant ,name
',value
))))
332 (make-instance ',class-name
:s
,value
))))
334 (setf all-specs
(append all-specs specs
))
335 (loop :for
(fun expected
) :on all-specs
:by
#'cddr
336 :do
(assert (eql (funcall (symbol-function slot-name
)
339 ;; Test constructors using the constant symbol and the relevant
341 (let ((constant-name (gensym)))
342 (define-constant constant-name
1)
343 (destructuring-bind (f-1-c f-1-1 f-1-2
)
344 (mapcar #'make
`(,constant-name
1 2))
345 (check f-1-c
1 f-1-1
1 f-1-2
2))
347 ;; Redefining the constant must not affect the existing
348 ;; constructors. New constructors must use the new value.
349 (define-constant constant-name
2)
350 (destructuring-bind (f-2-c f-2-1 f-2-2
)
351 (mapcar #'make
`(,constant-name
1 2))
352 (check f-2-c
2 f-2-1
1 f-2-2
2))
354 ;; Same for non-atom values, with the additional complication of
355 ;; preserving (non-)same-ness.
356 (let ((a1 '(:a
)) (a2 '(:a
)) (b '(:b
)))
357 (define-constant constant-name a1
)
358 (destructuring-bind (f-3-c f-3-a1 f-3-a2 f-3-b
)
359 (mapcar #'make
(list constant-name
`',a1
`',a2
`',b
))
360 (check f-3-c a1 f-3-a1 a1 f-3-a2 a2 f-3-b b
))
361 (define-constant constant-name b
)
362 (destructuring-bind (f-4-c f-4-a1 f-4-a2 f-4-b
)
363 (mapcar #'make
(list constant-name
`',a1
`',a2
`',b
))
364 (check f-4-c b f-4-a1 a1 f-4-a2 a2 f-4-b b
))))
366 ;; A different constant with the same value must not cause
368 (let ((constant-name-1 (gensym))
369 (constant-name-2 (gensym)))
370 (define-constant constant-name-1
1)
371 (define-constant constant-name-2
1)
372 (destructuring-bind (f-5-d-c f-5-d-1 f-5-d-2
)
373 (mapcar #'make
`(,constant-name-1
1 2))
374 (check f-5-d-c
1 f-5-d-1
1 f-5-d-2
2))
375 (destructuring-bind (f-5-e-c f-5-e-1 f-5-e-2
)
376 (mapcar #'make
`(,constant-name-2
1 2))
377 (check f-5-e-c
1 f-5-e-1
1 f-5-e-2
2))
378 (define-constant constant-name-1
2)
379 (destructuring-bind (f-6-d-c f-6-d-1 f-6-d-2
)
380 (mapcar #'make
`(,constant-name-1
1 2))
381 (check f-6-d-c
2 f-6-d-1
1 f-6-d-2
2))
382 (destructuring-bind (f-6-e-c f-6-e-1 f-6-e-2
)
383 (mapcar #'make
`(,constant-name-2
1 2))
384 (check f-6-e-c
1 f-6-e-1
1 f-6-e-2
2))))))