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 (let* ((cmacro (compiler-macro-function 'make-instance))
 100         (opt 0)
 101         (wrapper (lambda (form env)
 102                    (let ((res (funcall cmacro form env)))
 103                      (unless (eq form res)
 104                        (incf opt))
 105                      res))))
 106    (sb-ext:without-package-locks
 107      (unwind-protect
 108           (progn
 109             (setf (compiler-macro-function 'make-instance) wrapper)
 110             (with-test (:name (make-instance :non-constant-class))
 111               (assert (= 0 opt))
 112               (let ((f (compile nil `(lambda (class)
 113                                        (make-instance class :b t)))))
 114                 (assert (find-ctor-cache f))
 115                 (assert (= 1 opt))
 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)))
 121                 (assert (= 2 opt))
 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)))
 127                 (assert (= 3 opt))
 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)))
 133                 (assert (= 4 opt))
 134                 (assert (typep (funcall f) 'structure-object)))))
 135        (setf (compiler-macro-function 'make-instance) cmacro))))
 136
 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) () ())))))
 141          (count 0)
 142          (cache (find-ctor-cache f)))
 143     (assert cache)
 144     (assert (not (cdr cache)))
 145     (dolist (class classes)
 146       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 147       (incf count)
 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)))
 153             (t
 154              (assert (simple-vector-p (cdr cache))))))
 155     (dolist (class classes)
 156       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
 157       (incf count))))
 158 \f
 159 ;;;; success