tests/ctor.impure.lisp

   1 ;;;; gray-box testing of the constructor optimization machinery
   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 (load "test-util.lisp")
  15 (load "compiler-test-util.lisp")
  16
  17 (defpackage "CTOR-TEST"
  18   (:use "CL" "TEST-UTIL" "COMPILER-TEST-UTIL"))
  19
  20 (in-package "CTOR-TEST")
  21 \f
  22 (defclass no-slots () ())
  23
  24 (defun make-no-slots ()
  25   (make-instance 'no-slots))
  26 (compile 'make-no-slots)
  27
  28 ;; Note: this test may no longer be relevant. It asserted laziness of
  29 ;; the hash computation, since it was slow at some point, and it was
  30 ;; the root cause of slow instance creation. But that was fixed,
  31 ;; and we really don't care per se that hashing is lazy.
  32 #-compact-instance-header ; can't create symbols in SB-PCL
  33 (with-test (:name :instance-hash-starts-as-0)
  34   ;; These first two tests look the same but they aren't:
  35   ;; the second one uses a CTOR function.
  36   (assert (zerop (sb-kernel:%instance-ref (make-instance 'no-slots)
  37                                           sb-pcl::std-instance-hash-slot-index)))
  38   (assert (zerop (sb-kernel:%instance-ref (make-no-slots)
  39                                           sb-pcl::std-instance-hash-slot-index)))
  40   (assert (not (zerop (sxhash (make-no-slots))))))
  41
  42 (defmethod update-instance-for-redefined-class
  43     ((object no-slots) added discarded plist &rest initargs)
  44   (declare (ignore initargs))
  45   (error "Called U-I-F-R-C on ~A" object))
  46
  47 (assert (typep (make-no-slots) 'no-slots))
  48
  49 (make-instances-obsolete 'no-slots)
  50
  51 (assert (typep (make-no-slots) 'no-slots))
  52 (assert (typep (funcall (gethash '(sb-pcl::ctor no-slots nil) sb-pcl::*all-ctors*)) 'no-slots))
  53 \f
  54 (defclass one-slot ()
  55   ((a :initarg :a)))
  56
  57 (defun make-one-slot-a (a)
  58   (make-instance 'one-slot :a a))
  59 (compile 'make-one-slot-a)
  60 (defun make-one-slot-noa ()
  61   (make-instance 'one-slot))
  62 (compile 'make-one-slot-noa)
  63
  64 (defmethod update-instance-for-redefined-class
  65     ((object one-slot) added discarded plist &rest initargs)
  66   (declare (ignore initargs))
  67   (error "Called U-I-F-R-C on ~A" object))
  68
  69 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  70 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  71
  72 (make-instances-obsolete 'one-slot)
  73
  74 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  75 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot nil :a sb-pcl::\.p0.) sb-pcl::*all-ctors*)
  76                                 4) 'a) 4))
  77 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  78 (assert (not (slot-boundp (funcall (gethash '(sb-pcl::ctor one-slot nil) sb-pcl::*all-ctors*)) 'a)))
  79 \f
  80 (defclass one-slot-superclass ()
  81   ((b :initarg :b)))
  82 (defclass one-slot-subclass (one-slot-superclass)
  83   ())
  84
  85 (defun make-one-slot-subclass (b)
  86   (make-instance 'one-slot-subclass :b b))
  87 (compile 'make-one-slot-subclass)
  88
  89 (defmethod update-instance-for-redefined-class
  90     ((object one-slot-superclass) added discarded plist &rest initargs)
  91   (declare (ignore initargs))
  92   (error "Called U-I-F-R-C on ~A" object))
  93
  94 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  95
  96 (make-instances-obsolete 'one-slot-subclass)
  97
  98 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  99 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) sb-pcl::*all-ctors*)
 100                                 3) 'b) 3))
 101 (make-instances-obsolete 'one-slot-superclass)
 102
 103 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
 104 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) sb-pcl::*all-ctors*)
 105                                 4) 'b) 4))
 106
 107 ;;; Tests for CTOR optimization of non-constant class args and constant class object args
 108 (defun find-ctor-caches (fun)
 109   (remove-if-not (lambda (value)
 110                    (and (consp value) (eq 'sb-pcl::ctor-cache (car value))))
 111                  (find-code-constants fun)))
 112
 113 (let* ((transform (sb-int:info :function :source-transform 'make-instance))
 114         (opt 0)
 115         (wrapper (lambda (form env)
 116                    (let ((res (funcall transform form env)))
 117                      (unless (eq form res)
 118                        (incf opt))
 119                      res))))
 120    (sb-ext:without-package-locks
 121      (unwind-protect
 122           (progn
 123             (setf (sb-int:info :function :source-transform 'make-instance) wrapper)
 124             (with-test (:name (make-instance :non-constant-class))
 125               (assert (= 0 opt))
 126               (let ((f (checked-compile `(lambda (class)
 127                                            (make-instance class :b t)))))
 128                 (assert (= 1 (length (find-ctor-caches f))))
 129                 (assert (= 1 opt))
 130                 (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass))))
 131             (with-test (:name (make-instance :constant-class-object))
 132               (let ((f (checked-compile `(lambda ()
 133                                            (make-instance ,(find-class 'one-slot-subclass) :b t)))))
 134                 (assert (not (find-ctor-caches f)))
 135                 (assert (= 2 opt))
 136                 (assert (typep (funcall f) 'one-slot-subclass))))
 137             (with-test (:name (make-instance :constant-non-std-class-object))
 138               (let ((f (checked-compile `(lambda ()
 139                                            (make-instance ,(find-class 'structure-object))))))
 140                 (assert (not (find-ctor-caches f)))
 141                 (assert (= 3 opt))
 142                 (assert (typep (funcall f) 'structure-object))))
 143             (with-test (:name (make-instance :constant-non-std-class-name))
 144               (let ((f (checked-compile `(lambda ()
 145                                            (make-instance 'structure-object)))))
 146                 (assert (not (find-ctor-caches f)))
 147                 (assert (= 4 opt))
 148                 (assert (typep (funcall f) 'structure-object)))))
 149        (setf (sb-int:info :function :source-transform 'make-instance) transform))))
 150
 151 (with-test (:name (make-instance :ctor-inline-cache-resize))
 152   (let* ((f (checked-compile `(lambda (name) (make-instance name))))
 153          (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+)
 154                         collect (class-name (eval `(defclass ,(gentemp) () ())))))
 155          (count 0)
 156          (caches (find-ctor-caches f))
 157          (cache (pop caches)))
 158     (assert cache)
 159     (assert (not caches))
 160     (assert (not (cdr cache)))
 161     (dolist (class classes)
 162       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 163       (incf count)
 164       (cond ((<= count sb-pcl::+ctor-list-max-size+)
 165              (unless (consp (cdr cache))
 166                (error "oops, wanted list cache, got: ~S" cache))
 167              (unless (= count (length (cdr cache)))
 168                (error "oops, wanted ~S elts in cache, got: ~S" count cache)))
 169             (t
 170              (assert (simple-vector-p (cdr cache))))))
 171     (dolist (class classes)
 172       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 173       (incf count))))
 174
 175 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
 176 (defclass some-class ()
 177   ((aroundp :initform nil :reader aroundp))
 178   (:default-initargs :x :success1))
 179
 180 (defmethod shared-initialize :around ((some-class some-class) slots &key (x :fail?))
 181   (unless (eq x :success1)
 182     (error "Default initarg lossage"))
 183   (setf (slot-value some-class 'aroundp) t)
 184   (when (next-method-p)
 185     (call-next-method)))
 186
 187 (with-test (:name (make-instance :ctor-default-initargs-1))
 188   (assert (aroundp (eval `(make-instance 'some-class))))
 189   (let ((fun (checked-compile `(lambda () (make-instance 'some-class)))))
 190     (assert (aroundp (funcall fun)))
 191     ;; make sure we tested what we think we tested...
 192     (let ((ctors (find-anonymous-callees fun :type 'sb-pcl::ctor)))
 193       (assert ctors)
 194       (assert (not (cdr ctors)))
 195       (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
 196
 197 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
 198 ;;; in more interesting cases as well...
 199 (defparameter *some-counter* 0)
 200 (let* ((x 'success2))
 201   (defclass some-class2 ()
 202     ((aroundp :initform nil :reader aroundp))
 203     (:default-initargs :x (progn (incf *some-counter*) x))))
 204
 205 (defmethod shared-initialize :around ((some-class some-class2) slots &key (x :fail2?))
 206   (unless (eq x 'success2)
 207     (error "Default initarg lossage"))
 208   (setf (slot-value some-class 'aroundp) t)
 209   (when (next-method-p)
 210     (call-next-method)))
 211
 212 (with-test (:name (make-instance :ctor-default-initargs-2))
 213   (assert (= 0 *some-counter*))
 214   (assert (aroundp (eval `(make-instance 'some-class2))))
 215   (assert (= 1 *some-counter*))
 216   (let ((fun (checked-compile `(lambda () (make-instance 'some-class2)))))
 217     (assert (= 1 *some-counter*))
 218     (assert (aroundp (funcall fun)))
 219     (assert (= 2 *some-counter*))
 220     ;; make sure we tested what we think we tested...
 221     (let ((ctors (find-anonymous-callees fun :type 'sb-pcl::ctor)))
 222       (assert ctors)
 223       (assert (not (cdr ctors)))
 224       (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
 225
 226 ;;; No compiler notes, please
 227 (locally (declare (optimize safety))
 228   (defclass type-check-thing ()
 229     ((slot :type (integer 0) :initarg :slot))))
 230 (with-test (:name (make-instance :no-compile-note-at-runtime))
 231   (let ((fun (checked-compile `(lambda (x)
 232                                  (declare (optimize safety))
 233                                  (make-instance 'type-check-thing :slot x)))))
 234     (handler-bind ((sb-ext:compiler-note #'error))
 235       (funcall fun 41)
 236       (funcall fun 13))))
 237
 238 ;;; NO-APPLICABLE-METHOD called
 239 (defmethod no-applicable-method ((gf (eql #'make-instance)) &rest args)
 240   (cons :no-applicable-method args))
 241 (with-test (:name :constant-invalid-class-arg)
 242   (checked-compile-and-assert ()
 243       `(lambda (x) (make-instance "FOO" :quux x))
 244     ((14) '(:no-applicable-method "FOO" :quux 14)))
 245   (checked-compile-and-assert ()
 246       `(lambda (x y) (make-instance ''abc 'zot x 'bar y))
 247     ((1 2) '(:no-applicable-method 'abc zot 1 bar 2))))
 248
 249 (with-test (:name :variable-invalid-class-arg)
 250   (checked-compile-and-assert ()
 251       `(lambda (c x) (make-instance c :quux x))
 252     (("FOO" 14) '(:no-applicable-method "FOO" :quux 14)))
 253   (checked-compile-and-assert ()
 254       `(lambda (c x y) (make-instance c 'zot x 'bar y))
 255     ((''abc 1 2) '(:no-applicable-method 'abc zot 1 bar 2))))
 256
 257 (defclass sneaky-class (standard-class)
 258   ())
 259
 260 (defmethod sb-mop:validate-superclass ((class sneaky-class) (super standard-class))
 261   t)
 262
 263 (defclass sneaky ()
 264   ((dirty :initform nil :accessor dirty-slots)
 265    (a :initarg :a :reader sneaky-a)
 266    (b :initform "b" :reader sneaky-b)
 267    (c :accessor sneaky-c))
 268   (:metaclass sneaky-class))
 269
 270 (defvar *supervising* nil)
 271
 272 (defmethod (setf sb-mop:slot-value-using-class)
 273     :before (value (class sneaky-class) (instance sneaky) slotd)
 274   (unless *supervising*
 275     (let ((name (sb-mop:slot-definition-name slotd))
 276           (*supervising* t))
 277       (when (slot-boundp instance 'dirty)
 278         (pushnew name (dirty-slots instance))))))
 279
 280 (with-test (:name (make-instance :setf-slot-value-using-class-hits-other-slots))
 281   (let ((fun (checked-compile `(lambda (a c)
 282                                  (let ((i (make-instance 'sneaky :a a)))
 283                                    (setf (sneaky-c i) c)
 284                                    i)))))
 285     (loop repeat 3
 286           do (let ((i (funcall fun "a" "c")))
 287                (assert (equal '(c b a) (dirty-slots i)))
 288                (assert (equal "a" (sneaky-a i)))
 289                (assert (equal "b" (sneaky-b i)))
 290                (assert (equal "c" (sneaky-c i)))))))
 291
 292 (defclass bug-728650-base ()
 293   ((value
 294     :initarg :value
 295     :initform nil)))
 296
 297 (defmethod initialize-instance :after ((instance bug-728650-base) &key)
 298   (with-slots (value) instance
 299     (unless value
 300       (error "Impossible! Value slot not initialized in ~S" instance))))
 301
 302 (defclass bug-728650-child-1 (bug-728650-base)
 303   ())
 304
 305 (defmethod initialize-instance :around ((instance bug-728650-child-1) &rest initargs &key)
 306   (apply #'call-next-method instance :value 'provided-by-child-1 initargs))
 307
 308 (defclass bug-728650-child-2 (bug-728650-base)
 309   ())
 310
 311 (defmethod initialize-instance :around ((instance bug-728650-child-2) &rest initargs &key)
 312   (let ((foo (make-instance 'bug-728650-child-1)))
 313     (apply #'call-next-method instance :value foo initargs)))
 314
 315 (with-test (:name :bug-728650)
 316   (let ((child1 (slot-value (make-instance 'bug-728650-child-2) 'value)))
 317     (assert (typep child1 'bug-728650-child-1))
 318     (assert (eq 'provided-by-child-1 (slot-value child1 'value)))))
 319
 320 (defclass test-fancy-cnm () ((a :initarg :a)))
 321 (defmethod initialize-instance :around ((self test-fancy-cnm) &rest args)
 322   ;; WALK-METHOD-LAMBDA would get to the second form of CALL-NEXT-METHOD
 323   ;; and set the CALL-NEXT-METHOD-P flag to :SIMPLE
 324   ;; even though it had already been set to T by the earlier call.
 325   (if t
 326       (call-next-method self :a `(expect-this ,(getf args :a)))
 327       (call-next-method)))
 328 (defun fancy-cnm-in-ii-test (x) (make-instance 'test-fancy-cnm :a x))
 329 (with-test (:name :bug-1397454)
 330   (assert (equal (slot-value (fancy-cnm-in-ii-test 'hi) 'a)
 331                  '(expect-this hi))))
 332
 333 (with-test (:name (make-instance :ctor
 334                    :constant-initarg :constant-redefinition
 335                    :bug-1644944))
 336   (let ((class-name (gensym))
 337         (slot-name (gensym))
 338         (all-specs '()))
 339     (eval `(defclass ,class-name () ((,slot-name :initarg :s
 340                                                  :reader ,slot-name))))
 341     (flet ((define-constant (name value)
 342              (handler-bind ((sb-ext:defconstant-uneql #'continue))
 343                (eval `(defconstant ,name ',value))))
 344            (make (value)
 345              (checked-compile
 346               `(lambda ()
 347                  (make-instance ',class-name :s ,value))))
 348            (check (&rest specs)
 349              (setf all-specs (append all-specs specs))
 350              (loop :for (fun expected) :on all-specs :by #'cddr
 351                 :do (assert (eql (funcall (symbol-function slot-name)
 352                                           (funcall fun))
 353                                  expected)))))
 354       ;; Test constructors using the constant symbol and the relevant
 355       ;; constant values.
 356       (let ((constant-name (gensym)))
 357         (define-constant constant-name 1)
 358         (destructuring-bind (f-1-c f-1-1 f-1-2)
 359             (mapcar #'make `(,constant-name 1 2))
 360           (check f-1-c 1 f-1-1 1 f-1-2 2))
 361
 362         ;; Redefining the constant must not affect the existing
 363         ;; constructors. New constructors must use the new value.
 364         (define-constant constant-name 2)
 365         (destructuring-bind (f-2-c f-2-1 f-2-2)
 366             (mapcar #'make `(,constant-name 1 2))
 367           (check f-2-c 2 f-2-1 1 f-2-2 2))
 368
 369         ;; Same for non-atom values, with the additional complication of
 370         ;; preserving (non-)same-ness.
 371         (let ((a1 '(:a)) (a2 '(:a)) (b '(:b)))
 372           (define-constant constant-name a1)
 373           (destructuring-bind (f-3-c f-3-a1 f-3-a2 f-3-b)
 374               (mapcar #'make (list constant-name `',a1 `',a2 `',b))
 375             (check f-3-c a1 f-3-a1 a1 f-3-a2 a2 f-3-b b))
 376           (define-constant constant-name b)
 377           (destructuring-bind (f-4-c f-4-a1 f-4-a2 f-4-b)
 378               (mapcar #'make (list constant-name `',a1 `',a2 `',b))
 379             (check f-4-c b f-4-a1 a1 f-4-a2 a2 f-4-b b))))
 380
 381       ;; A different constant with the same value must not cause
 382       ;; aliasing.
 383       (let ((constant-name-1 (gensym))
 384             (constant-name-2 (gensym)))
 385         (define-constant constant-name-1 1)
 386         (define-constant constant-name-2 1)
 387         (destructuring-bind (f-5-d-c f-5-d-1 f-5-d-2)
 388             (mapcar #'make `(,constant-name-1 1 2))
 389           (check f-5-d-c 1 f-5-d-1 1 f-5-d-2 2))
 390         (destructuring-bind (f-5-e-c f-5-e-1 f-5-e-2)
 391             (mapcar #'make `(,constant-name-2 1 2))
 392           (check f-5-e-c 1 f-5-e-1 1 f-5-e-2 2))
 393         (define-constant constant-name-1 2)
 394         (destructuring-bind (f-6-d-c f-6-d-1 f-6-d-2)
 395             (mapcar #'make `(,constant-name-1 1 2))
 396           (check f-6-d-c 2 f-6-d-1 1 f-6-d-2 2))
 397         (destructuring-bind (f-6-e-c f-6-e-1 f-6-e-2)
 398             (mapcar #'make `(,constant-name-2 1 2))
 399           (check f-6-e-c 1 f-6-e-1 1 f-6-e-2 2))))))