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 (let* ((cmacro (compiler-macro-function 'make-instance))
101 (wrapper (lambda (form env)
102 (let ((res (funcall cmacro form env)))
103 (unless (eq form res)
106 (sb-ext:without-package-locks
109 (setf (compiler-macro-function 'make-instance) wrapper)
110 (with-test (:name (make-instance :non-constant-class))
112 (let ((f (compile nil `(lambda (class)
113 (make-instance class :b t)))))
114 (assert (find-ctor-cache f))
116 (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass))))
117 (with-test (:name (make-instance :constant-class-object))
118 (let ((f (compile nil `(lambda ()
119 (make-instance ,(find-class 'one-slot-subclass) :b t)))))
120 (assert (not (find-ctor-cache f)))
122 (assert (typep (funcall f) 'one-slot-subclass))))
123 (with-test (:name (make-instance :constant-non-std-class-object))
124 (let ((f (compile nil `(lambda ()
125 (make-instance ,(find-class 'structure-object))))))
126 (assert (not (find-ctor-cache f)))
128 (assert (typep (funcall f) 'structure-object))))
129 (with-test (:name (make-instance :constant-non-std-class-name))
130 (let ((f (compile nil `(lambda ()
131 (make-instance 'structure-object)))))
132 (assert (not (find-ctor-cache f)))
134 (assert (typep (funcall f) 'structure-object)))))
135 (setf (compiler-macro-function 'make-instance) cmacro))))
137 (with-test (:name (make-instance :ctor-inline-cache-resize))
138 (let* ((f (compile nil `(lambda (name) (make-instance name))))
139 (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+)
140 collect (class-name (eval `(defclass ,(gentemp) () ())))))
142 (cache (find-ctor-cache f)))
144 (assert (not (cdr cache)))
145 (dolist (class classes)
146 (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
148 (cond ((<= count sb-pcl::+ctor-list-max-size+)
149 (unless (consp (cdr cache))
150 (error "oops, wanted list cache, got: ~S" cache))
151 (unless (= count (length (cdr cache)))
152 (error "oops, wanted ~S elts in cache, got: ~S" count cache)))
154 (assert (simple-vector-p (cdr cache))))))
155 (dolist (class classes)
156 (assert (typep (funcall f (if (oddp count) class (find-class class))) class))