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
  16 (defpackage "CTOR-TEST"
  17   (:use "CL" "TEST-UTIL"))
  18
  19 (in-package "CTOR-TEST")
  20 \f
  21 (defclass no-slots () ())
  22
  23 (defun make-no-slots ()
  24   (make-instance 'no-slots))
  25 (compile 'make-no-slots)
  26
  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))
  31
  32 (assert (typep (make-no-slots) 'no-slots))
  33
  34 (make-instances-obsolete 'no-slots)
  35
  36 (assert (typep (make-no-slots) 'no-slots))
  37 (assert (typep (funcall #'(sb-pcl::ctor no-slots nil)) 'no-slots))
  38 \f
  39 (defclass one-slot ()
  40   ((a :initarg :a)))
  41
  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)
  48
  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))
  53
  54 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
  55 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
  56
  57 (make-instances-obsolete 'one-slot)
  58
  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)))
  63 \f
  64 (defclass one-slot-superclass ()
  65   ((b :initarg :b)))
  66 (defclass one-slot-subclass (one-slot-superclass)
  67   ())
  68
  69 (defun make-one-slot-subclass (b)
  70   (make-instance 'one-slot-subclass :b b))
  71 (compile 'make-one-slot-subclass)
  72
  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))
  77
  78 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
  79
  80 (make-instances-obsolete 'one-slot-subclass)
  81
  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)
  85
  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))
  88
  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)))
  97                    (return c)))))))
  98
  99 ;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this
 100 ;;; as well.
 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)
 108                             (or (not namep)
 109                                 (equal name (sb-impl::fdefn-name c))))
 110                    (return fun)))))))
 111
 112 (let* ((cmacro (compiler-macro-function 'make-instance))
 113         (opt 0)
 114         (wrapper (lambda (form env)
 115                    (let ((res (funcall cmacro form env)))
 116                      (unless (eq form res)
 117                        (incf opt))
 118                      res))))
 119    (sb-ext:without-package-locks
 120      (unwind-protect
 121           (progn
 122             (setf (compiler-macro-function 'make-instance) wrapper)
 123             (with-test (:name (make-instance :non-constant-class))
 124               (assert (= 0 opt))
 125               (let ((f (compile nil `(lambda (class)
 126                                        (make-instance class :b t)))))
 127                 (assert (find-ctor-cache f))
 128                 (assert (= 1 opt))
 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)))
 134                 (assert (= 2 opt))
 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)))
 140                 (assert (= 3 opt))
 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)))
 146                 (assert (= 4 opt))
 147                 (assert (typep (funcall f) 'structure-object)))))
 148        (setf (compiler-macro-function 'make-instance) cmacro))))
 149
 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) () ())))))
 154          (count 0)
 155          (cache (find-ctor-cache f)))
 156     (assert cache)
 157     (assert (not (cdr cache)))
 158     (dolist (class classes)
 159       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 160       (incf count)
 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)))
 166             (t
 167              (assert (simple-vector-p (cdr cache))))))
 168     (dolist (class classes)
 169       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 170       (incf count))))
 171
 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 :success?))
 176 (defmethod initialize-instance :around ((some-class some-class) &key (x :fail?))
 177   (unless (eq x :success?)
 178     (error "Default initarg lossage"))
 179   (setf (slot-value some-class 'aroundp) t)
 180   (when (next-method-p)
 181     (call-next-method)))
 182 (with-test (:name (make-instance :ctor-default-initargs))
 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 ((ctor (find-callee fun :type 'sb-pcl::ctor)))
 188       (assert (find-callee ctor :name 'sb-pcl::fast-make-instance)))))
 189 \f
 190 ;;;; success