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 (with-test (:name :instance-hash-starts-as-0)
  29   ;; These first two tests look the same but they aren't:
  30   ;; the second one uses a CTOR function.
  31   (assert (zerop (sb-kernel:%instance-ref (make-instance 'no-slots)
  32                                           sb-pcl::std-instance-hash-slot-index)))
  33   (assert (zerop (sb-kernel:%instance-ref (make-no-slots)
  34                                           sb-pcl::std-instance-hash-slot-index)))
  35   (assert (not (zerop (sxhash (make-no-slots))))))
  36
  37 (defmethod update-instance-for-redefined-class
  38     ((object no-slots) added discarded plist &rest initargs)
  39   (declare (ignore initargs))
  40   (error "Called U-I-F-R-C on ~A" object))
  41
  42 (assert (typep (make-no-slots) 'no-slots))
  43
  44 (make-instances-obsolete 'no-slots)
  45
  46 (assert (typep (make-no-slots) 'no-slots))
  47 (assert (typep (funcall (gethash '(sb-pcl::ctor no-slots nil) sb-pcl::*all-ctors*)) 'no-slots))
  48 \f
  49 (defclass one-slot ()
  50   ((a :initarg :a)))
  51
  52 (defun make-one-slot-a (a)
  53   (make-instance 'one-slot :a a))
  54 (compile 'make-one-slot-a)
  55 (defun make-one-slot-noa ()
  56   (make-instance 'one-slot))
  57 (compile 'make-one-slot-noa)
  58
  59 (defmethod update-instance-for-redefined-class
  60     ((object one-slot) added discarded plist &rest initargs)
  61   (declare (ignore initargs))
  62   (error "Called U-I-F-R-C on ~A" object))
  63
  64 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  65 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  66
  67 (make-instances-obsolete 'one-slot)
  68
  69 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  70 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot nil :a sb-pcl::\.p0.) sb-pcl::*all-ctors*)
  71                                 4) 'a) 4))
  72 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  73 (assert (not (slot-boundp (funcall (gethash '(sb-pcl::ctor one-slot nil) sb-pcl::*all-ctors*)) 'a)))
  74 \f
  75 (defclass one-slot-superclass ()
  76   ((b :initarg :b)))
  77 (defclass one-slot-subclass (one-slot-superclass)
  78   ())
  79
  80 (defun make-one-slot-subclass (b)
  81   (make-instance 'one-slot-subclass :b b))
  82 (compile 'make-one-slot-subclass)
  83
  84 (defmethod update-instance-for-redefined-class
  85     ((object one-slot-superclass) added discarded plist &rest initargs)
  86   (declare (ignore initargs))
  87   (error "Called U-I-F-R-C on ~A" object))
  88
  89 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  90
  91 (make-instances-obsolete 'one-slot-subclass)
  92
  93 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  94 (assert (= (slot-value (funcall (gethash '(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) sb-pcl::*all-ctors*)
  95                                 3) 'b) 3))
  96 (make-instances-obsolete 'one-slot-superclass)
  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                                 4) 'b) 4))
 101
 102 ;;; Tests for CTOR optimization of non-constant class args and constant class object args
 103 (defun find-ctor-caches (fun)
 104   (remove-if-not (lambda (value)
 105                    (and (consp value) (eq 'sb-pcl::ctor-cache (car value))))
 106                  (find-value-cell-values fun)))
 107
 108 (let* ((transform (sb-int:info :function :source-transform 'make-instance))
 109         (opt 0)
 110         (wrapper (lambda (form env)
 111                    (let ((res (funcall transform form env)))
 112                      (unless (eq form res)
 113                        (incf opt))
 114                      res))))
 115    (sb-ext:without-package-locks
 116      (unwind-protect
 117           (progn
 118             (setf (sb-int:info :function :source-transform 'make-instance) wrapper)
 119             (with-test (:name (make-instance :non-constant-class))
 120               (assert (= 0 opt))
 121               (let ((f (compile nil `(lambda (class)
 122                                        (make-instance class :b t)))))
 123                 (assert (= 1 (length (find-ctor-caches f))))
 124                 (assert (= 1 opt))
 125                 (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass))))
 126             (with-test (:name (make-instance :constant-class-object))
 127               (let ((f (compile nil `(lambda ()
 128                                        (make-instance ,(find-class 'one-slot-subclass) :b t)))))
 129                 (assert (not (find-ctor-caches f)))
 130                 (assert (= 2 opt))
 131                 (assert (typep (funcall f) 'one-slot-subclass))))
 132             (with-test (:name (make-instance :constant-non-std-class-object))
 133               (let ((f (compile nil `(lambda ()
 134                                        (make-instance ,(find-class 'structure-object))))))
 135                 (assert (not (find-ctor-caches f)))
 136                 (assert (= 3 opt))
 137                 (assert (typep (funcall f) 'structure-object))))
 138             (with-test (:name (make-instance :constant-non-std-class-name))
 139               (let ((f (compile nil `(lambda ()
 140                                        (make-instance 'structure-object)))))
 141                 (assert (not (find-ctor-caches f)))
 142                 (assert (= 4 opt))
 143                 (assert (typep (funcall f) 'structure-object)))))
 144        (setf (sb-int:info :function :source-transform 'make-instance) transform))))
 145
 146 (with-test (:name (make-instance :ctor-inline-cache-resize))
 147   (let* ((f (compile nil `(lambda (name) (make-instance name))))
 148          (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+)
 149                         collect (class-name (eval `(defclass ,(gentemp) () ())))))
 150          (count 0)
 151          (caches (find-ctor-caches f))
 152          (cache (pop caches)))
 153     (assert cache)
 154     (assert (not caches))
 155     (assert (not (cdr cache)))
 156     (dolist (class classes)
 157       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 158       (incf count)
 159       (cond ((<= count sb-pcl::+ctor-list-max-size+)
 160              (unless (consp (cdr cache))
 161                (error "oops, wanted list cache, got: ~S" cache))
 162              (unless (= count (length (cdr cache)))
 163                (error "oops, wanted ~S elts in cache, got: ~S" count cache)))
 164             (t
 165              (assert (simple-vector-p (cdr cache))))))
 166     (dolist (class classes)
 167       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 168       (incf count))))
 169
 170 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
 171 (defclass some-class ()
 172   ((aroundp :initform nil :reader aroundp))
 173   (:default-initargs :x :success1))
 174
 175 (defmethod shared-initialize :around ((some-class some-class) slots &key (x :fail?))
 176   (unless (eq x :success1)
 177     (error "Default initarg lossage"))
 178   (setf (slot-value some-class 'aroundp) t)
 179   (when (next-method-p)
 180     (call-next-method)))
 181
 182 (with-test (:name (make-instance :ctor-default-initargs-1))
 183   (assert (aroundp (eval `(make-instance 'some-class))))
 184   (let ((fun (compile nil `(lambda () (make-instance 'some-class)))))
 185     (assert (aroundp (funcall fun)))
 186     ;; make sure we tested what we think we tested...
 187     (let ((ctors (find-anonymous-callees fun :type 'sb-pcl::ctor)))
 188       (assert ctors)
 189       (assert (not (cdr ctors)))
 190       (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
 191
 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))))
 199
 200 (defmethod shared-initialize :around ((some-class some-class2) slots &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)
 205     (call-next-method)))
 206
 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 ((ctors (find-anonymous-callees fun :type 'sb-pcl::ctor)))
 217       (assert ctors)
 218       (assert (not (cdr ctors)))
 219       (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
 220
 221 ;;; No compiler notes, please
 222 (locally (declare (optimize safety))
 223   (defclass type-check-thing ()
 224     ((slot :type (integer 0) :initarg :slot))))
 225 (with-test (:name (make-instance :no-compile-note-at-runtime))
 226   (let ((fun (compile nil `(lambda (x)
 227                              (declare (optimize safety))
 228                              (make-instance 'type-check-thing :slot x)))))
 229     (handler-bind ((sb-ext:compiler-note #'error))
 230       (funcall fun 41)
 231       (funcall fun 13))))
 232
 233 ;;; NO-APPLICABLE-METHOD called
 234 (defmethod no-applicable-method ((gf (eql #'make-instance)) &rest args)
 235   (cons :no-applicable-method args))
 236 (with-test (:name :constant-invalid-class-arg)
 237   (assert (equal
 238            '(:no-applicable-method "FOO" :quux 14)
 239            (funcall (compile nil `(lambda (x) (make-instance "FOO" :quux x))) 14)))
 240   (assert (equal
 241            '(:no-applicable-method 'abc zot 1 bar 2)
 242            (funcall (compile nil `(lambda (x y) (make-instance ''abc 'zot x 'bar y)))
 243                     1 2))))
 244 (with-test (:name :variable-invalid-class-arg)
 245   (assert (equal
 246            '(:no-applicable-method "FOO" :quux 14)
 247            (funcall (compile nil `(lambda (c x) (make-instance c :quux x))) "FOO" 14)))
 248   (assert (equal
 249            '(:no-applicable-method 'abc zot 1 bar 2)
 250            (funcall (compile nil `(lambda (c x y) (make-instance c 'zot x 'bar y)))
 251                     ''abc 1 2))))
 252
 253 (defclass sneaky-class (standard-class)
 254   ())
 255
 256 (defmethod sb-mop:validate-superclass ((class sneaky-class) (super standard-class))
 257   t)
 258
 259 (defclass sneaky ()
 260   ((dirty :initform nil :accessor dirty-slots)
 261    (a :initarg :a :reader sneaky-a)
 262    (b :initform "b" :reader sneaky-b)
 263    (c :accessor sneaky-c))
 264   (:metaclass sneaky-class))
 265
 266 (defvar *supervising* nil)
 267
 268 (defmethod (setf sb-mop:slot-value-using-class)
 269     :before (value (class sneaky-class) (instance sneaky) slotd)
 270   (unless *supervising*
 271     (let ((name (sb-mop:slot-definition-name slotd))
 272           (*supervising* t))
 273       (when (slot-boundp instance 'dirty)
 274         (pushnew name (dirty-slots instance))))))
 275
 276 (with-test (:name (make-instance :setf-slot-value-using-class-hits-other-slots))
 277   (let ((fun (compile nil `(lambda (a c)
 278                              (let ((i (make-instance 'sneaky :a a)))
 279                                (setf (sneaky-c i) c)
 280                                i)))))
 281     (loop repeat 3
 282           do (let ((i (funcall fun "a" "c")))
 283                (assert (equal '(c b a) (dirty-slots i)))
 284                (assert (equal "a" (sneaky-a i)))
 285                (assert (equal "b" (sneaky-b i)))
 286                (assert (equal "c" (sneaky-c i)))))))
 287
 288 (defclass bug-728650-base ()
 289   ((value
 290     :initarg :value
 291     :initform nil)))
 292
 293 (defmethod initialize-instance :after ((instance bug-728650-base) &key)
 294   (with-slots (value) instance
 295     (unless value
 296       (error "Impossible! Value slot not initialized in ~S" instance))))
 297
 298 (defclass bug-728650-child-1 (bug-728650-base)
 299   ())
 300
 301 (defmethod initialize-instance :around ((instance bug-728650-child-1) &rest initargs &key)
 302   (apply #'call-next-method instance :value 'provided-by-child-1 initargs))
 303
 304 (defclass bug-728650-child-2 (bug-728650-base)
 305   ())
 306
 307 (defmethod initialize-instance :around ((instance bug-728650-child-2) &rest initargs &key)
 308   (let ((foo (make-instance 'bug-728650-child-1)))
 309     (apply #'call-next-method instance :value foo initargs)))
 310
 311 (with-test (:name :bug-728650)
 312   (let ((child1 (slot-value (make-instance 'bug-728650-child-2) 'value)))
 313     (assert (typep child1 'bug-728650-child-1))
 314     (assert (eq 'provided-by-child-1 (slot-value child1 'value)))))
 315
 316 (defclass test-fancy-cnm () ((a :initarg :a)))
 317 (defmethod initialize-instance :around ((self test-fancy-cnm) &rest args)
 318   ;; WALK-METHOD-LAMBDA would get to the second form of CALL-NEXT-METHOD
 319   ;; and set the CALL-NEXT-METHOD-P flag to :SIMPLE
 320   ;; even though it had already been set to T by the earlier call.
 321   (if t
 322       (call-next-method self :a `(expect-this ,(getf args :a)))
 323       (call-next-method)))
 324 (defun fancy-cnm-in-ii-test (x) (make-instance 'test-fancy-cnm :a x))
 325 (with-test (:name :bug-1397454)
 326   (assert (equal (slot-value (fancy-cnm-in-ii-test 'hi) 'a)
 327                  '(expect-this hi))))
 328 \f
 329 ;;;; success