From: Nikodemus Siivola Date: Thu, 25 Jun 2009 14:55:41 +0000 (+0000) Subject: 1.0.29.41: inline CTOR caches for MAKE-INSTANCE X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=95d19447c10434753c2168ac943152fd5e3ded3d;p=sbcl.git 1.0.29.41: inline CTOR caches for MAKE-INSTANCE * If MAKE-INSTANCE has constant keywords but a variable first argument, build an inline cache of CTORs. ** Initially a sorted list, switching to a max 256 entry table if the list grows too large. ** Rename CTOR-NAME to CTOR-NAME-OR-CLASS, and allow building CTORs for class arguments as wel. Similarly, CTOR function names can contain class objects as well. ** Factor out RANDOMLY-PUNTING-LAMBDA from cache.lisp, since CTOR cache wants it too. ** STD-INSTANCE-P and FSC-INSTANCE-P become functions with compiler macros -- they are now used in compiler-support.lisp, which is built before low.lisp, so using macros is out. * Also enable the existing CTOR optimization for constant class objects as class arguments. * Tests. --- diff --git a/NEWS b/NEWS index e6ccfbf..b917c8d 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,8 @@ values in other threads. * new feature: SB-INTROSPECT:ALLOCATION-INFORMATION provides information about object allocation. + * optimization: MAKE-INSTANCE with non-constant class-argument but constant + keywords is an order of magnitude faster. * optimization: more efficient type-checks for FIXNUMs when the value is known to be a signed word on x86 and x86-64. * optimization: compiler now optimizes (EXPT -1 INTEGER), (EXPT -1.0 INTEGER), diff --git a/contrib/sb-queue/test-queue.lisp b/contrib/sb-queue/test-queue.lisp index 519d032..3a0b2a5 100644 --- a/contrib/sb-queue/test-queue.lisp +++ b/contrib/sb-queue/test-queue.lisp @@ -19,7 +19,7 @@ (assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil)))))) (let ((x (make-instance 'structure-object)) - (y (make-queue))) + (y (make-queue))) (assert (not (typep x 'queue))) (assert (not (queuep x))) (assert (typep y 'queue)) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 73c197b..bb60a03 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -317,8 +317,6 @@ ;; Make a smaller one, then (make-cache :key-count key-count :value value :size (ceiling size 2))))) -(defconstant n-fixnum-bits #.(integer-length most-positive-fixnum)) - ;;;; Copies and expands the cache, dropping any invalidated or ;;;; incomplete lines. (defun copy-and-expand-cache (cache layouts value) @@ -357,18 +355,8 @@ ;; _Experimentally_ 50% seems to perform the ;; best, but it would be nice to have a proper ;; analysis... - (flet ((random-fixnum () - (random (1+ most-positive-fixnum)))) - (let ((drops (random-fixnum)) - (drop-pos n-fixnum-bits)) - (declare (fixnum drops) - (type (integer 0 #.n-fixnum-bits) drop-pos)) - (lambda (layouts value) - (when (logbitp (the unsigned-byte (decf drop-pos)) drops) - (try-update-cache copy layouts value)) - (when (zerop drop-pos) - (setf drops (random-fixnum) - drop-pos n-fixnum-bits))))) + (randomly-punting-lambda (layouts value) + (try-update-cache copy layouts value)) (lambda (layouts value) (unless (try-update-cache copy layouts value) ;; Didn't fit -- expand the cache, or drop diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index f7da509..5dcd8c6 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -84,7 +84,13 @@ (valid-function-name-p (cadr list))) (define-internal-pcl-function-name-syntax sb-pcl::ctor (list) - (valid-function-name-p (cadr list))) + (let ((class-or-name (cadr list))) + (cond + ((symbolp class-or-name) + (values (valid-function-name-p class-or-name) nil)) + ((or (sb-pcl::std-instance-p class-or-name) + (sb-pcl::fsc-instance-p class-or-name)) + (values t nil))))) ;;;; SLOT-VALUE optimizations diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index aebc884..26b64e2 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -84,6 +84,13 @@ else if (or (null test) (funcall test (car more))) collect (car more))) +(defun constant-class-arg-p (form) + (and (constantp form) + (let ((constant (constant-form-value form))) + (or (and (symbolp constant) + (not (null (symbol-package constant)))) + (classp form))))) + (defun constant-symbol-p (form) (and (constantp form) (let ((constant (constant-form-value form))) @@ -107,7 +114,7 @@ ;;; funcallable instance is set to it. ;;; (!defstruct-with-alternate-metaclass ctor - :slot-names (function-name class-name class initargs safe-p) + :slot-names (function-name class-or-name class initargs safe-p) :boa-constructor %make-ctor :superclass-name function :metaclass-name static-classoid @@ -116,7 +123,6 @@ :runtime-type-checks-p nil) ;;; List of all defined ctors. - (defvar *all-ctors* ()) (defun make-ctor-parameter-list (ctor) @@ -126,13 +132,14 @@ ;;; optimized constructor function when called. (defun install-initial-constructor (ctor &key force-p) (when (or force-p (ctor-class ctor)) - (setf (ctor-class ctor) nil) - (setf (funcallable-instance-fun ctor) - #'(lambda (&rest args) - (install-optimized-constructor ctor) - (apply ctor args))) - (setf (%funcallable-instance-info ctor 1) - (ctor-function-name ctor)))) + (let ((*installing-ctor* t)) + (setf (ctor-class ctor) nil) + (setf (funcallable-instance-fun ctor) + #'(lambda (&rest args) + (install-optimized-constructor ctor) + (apply ctor args))) + (setf (%funcallable-instance-info ctor 1) + (ctor-function-name ctor))))) (defun make-ctor-function-name (class-name initargs safe-code-p) (list* 'ctor class-name safe-code-p initargs)) @@ -150,20 +157,185 @@ (setf (fdefinition function-name) ctor) (install-initial-constructor ctor :force-p t) ctor))) - + +;;; ***************** +;;; Inline CTOR cache +;;; ***************** +;;; +;;; The cache starts out as a list of CTORs, sorted with the most recently +;;; used CTORs near the head. If it expands too much, we switch to a vector +;;; with a simple hashing scheme. + +;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR +;;; is in the list but not one of the 4 first ones, return a new list with the +;;; found CTOR at the head. Thread-safe: the new list shares structure with +;;; the old, but is not desctructively modified. Returning the old list for +;;; hits close to the head reduces ping-ponging with multiple threads seeking +;;; the same list. +(defun find-ctor (key list) + (labels ((walk (tail from-head depth) + (declare (fixnum depth)) + (if tail + (let ((ctor (car tail))) + (if (eq (ctor-class-or-name ctor) key) + (if (> depth 3) + (values ctor + (nconc (list ctor) (nreverse from-head) (cdr tail))) + (values ctor + list)) + (walk (cdr tail) + (cons ctor from-head) + (logand #xf (1+ depth))))) + (values nil list)))) + (walk list nil 0))) + +(declaim (inline sxhash-symbol-or-class)) +(defun sxhash-symbol-or-class (x) + (cond ((symbolp x) (sxhash x)) + ((std-instance-p x) (std-instance-hash x)) + ((fsc-instance-p x) (fsc-instance-hash x)) + (t + (bug "Something strange where symbol or class expected.")))) + +;;; Max number of CTORs kept in an inline list cache. Once this is +;;; exceeded we switch to a table. +(defconstant +ctor-list-max-size+ 12) +;;; Max table size for CTOR cache. If the table fills up at this size +;;; we keep the same size and drop 50% of the old entries. +(defconstant +ctor-table-max-size+ (expt 2 8)) +;;; Even if there is space in the cache, if we cannot fit a new entry +;;; with max this number of collisions we expand the table (if possible) +;;; and rehash. +(defconstant +ctor-table-max-probe-depth+ 5) + +(defun make-ctor-table (size) + (declare (index size)) + (let ((real-size (power-of-two-ceiling size))) + (if (< real-size +ctor-table-max-size+) + (values (make-array real-size :initial-element nil) nil) + (values (make-array +ctor-table-max-size+ :initial-element nil) t)))) + +(declaim (inline mix-ctor-hash)) +(defun mix-ctor-hash (hash base) + (logand most-positive-fixnum (+ hash base 1))) + +(defun put-ctor (ctor table) + (cond ((try-put-ctor ctor table) + (values ctor table)) + (t + (expand-ctor-table ctor table)))) + +;;; Thread-safe: if two threads write to the same index in parallel, the other +;;; result is just lost. This is not an issue as the CTORs are used as their +;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other +;;; one is needed we just cache it again -- hopefully not getting stomped on +;;; that time. +(defun try-put-ctor (ctor table) + (declare (simple-vector table) (optimize speed)) + (let* ((class (ctor-class-or-name ctor)) + (base (sxhash-symbol-or-class class)) + (hash base) + (mask (1- (length table)))) + (declare (fixnum base hash mask)) + (loop repeat +ctor-table-max-probe-depth+ + do (let* ((index (logand mask hash)) + (old (aref table index))) + (cond ((and old (neq class (ctor-class-or-name old))) + (setf hash (mix-ctor-hash hash base))) + (t + (setf (aref table index) ctor) + (return-from try-put-ctor t))))) + ;; Didn't fit, must expand + nil)) + +(defun get-ctor (class table) + (declare (simple-vector table) (optimize speed)) + (let* ((base (sxhash-symbol-or-class class)) + (hash base) + (mask (1- (length table)))) + (declare (fixnum base hash mask)) + (loop repeat +ctor-table-max-probe-depth+ + do (let* ((index (logand mask hash)) + (old (aref table index))) + (if (and old (eq class (ctor-class-or-name old))) + (return-from get-ctor old) + (setf hash (mix-ctor-hash hash base))))) + ;; Nothing. + nil)) + +;;; Thread safe: the old table is read, but if another thread mutates +;;; it while we're reading we still get a sane result -- either the old +;;; or the new entry. The new table is locally allocated, so that's ok +;;; too. +(defun expand-ctor-table (ctor old) + (declare (simple-vector old)) + (let* ((old-size (length old)) + (new-size (* 2 old-size)) + (drop-random-entries nil)) + (tagbody + :again + (multiple-value-bind (new max-size-p) (make-ctor-table new-size) + (let ((action (if drop-random-entries + ;; Same logic as in method caches -- see comment + ;; there. + (randomly-punting-lambda (old-ctor) + (try-put-ctor old-ctor new)) + (lambda (old-ctor) + (unless (try-put-ctor old-ctor new) + (if max-size-p + (setf drop-random-entries t) + (setf new-size (* 2 new-size))) + (go :again)))))) + (aver (try-put-ctor ctor new)) + (dotimes (i old-size) + (let ((old-ctor (aref old i))) + (when old-ctor + (funcall action old-ctor)))) + (return-from expand-ctor-table (values ctor new))))))) + +(defun ctor-list-to-table (list) + (let ((table (make-ctor-table (length list)))) + (dolist (ctor list) + (setf table (nth-value 1 (put-ctor ctor table)))) + table)) + +(defun ctor-for-caching (class-name initargs safe-code-p) + (let ((name (make-ctor-function-name class-name initargs safe-code-p))) + (or (ensure-ctor name class-name initargs safe-code-p) + (fdefinition name)))) + +(defun ensure-cached-ctor (class-name store initargs safe-code-p) + (if (listp store) + (multiple-value-bind (ctor list) (find-ctor class-name store) + (if ctor + (values ctor list) + (let ((ctor (ctor-for-caching class-name initargs safe-code-p))) + (if (< (length list) +ctor-list-max-size+) + (values ctor (cons ctor list)) + (values ctor (ctor-list-to-table list)))))) + (let ((ctor (get-ctor class-name store))) + (if ctor + (values ctor store) + (put-ctor (ctor-for-caching class-name initargs safe-code-p) + store))))) ;;; *********************************************** ;;; Compile-Time Expansion of MAKE-INSTANCE ******* ;;; *********************************************** +(defvar *compiling-optimized-constructor* nil) + (define-compiler-macro make-instance (&whole form &rest args &environment env) (declare (ignore args)) - (or (make-instance->constructor-call form (safe-code-p env)) + ;; Compiling an optimized constructor for a non-standard class means compiling a + ;; lambda with (MAKE-INSTANCE # ...) in it -- need + ;; to make sure we don't recurse there. + (or (unless *compiling-optimized-constructor* + (make-instance->constructor-call form (safe-code-p env))) form)) (defun make-instance->constructor-call (form safe-code-p) - (destructuring-bind (fn class-name &rest args) form - (declare (ignore fn)) + (destructuring-bind (class-arg &rest args) (cdr form) (flet (;; ;; Return the name of parameter number I of a constructor ;; function. @@ -172,20 +344,18 @@ (if (array-in-bounds-p ps i) (aref ps i) (format-symbol *pcl-package* ".P~D." i)))) - ;; Check if CLASS-NAME is a constant symbol. Give up if + ;; Check if CLASS-ARG is a constant symbol. Give up if ;; not. - (check-class () - (unless (and class-name (constant-symbol-p class-name)) - (return-from make-instance->constructor-call nil))) + (constant-class-p () + (and class-arg (constant-class-arg-p class-arg))) ;; Check if ARGS are suitable for an optimized constructor. ;; Return NIL from the outer function if not. (check-args () (loop for (key . more) on args by #'cddr do - (when (or (null more) - (not (constant-symbol-p key)) - (eq :allow-other-keys (constant-form-value key))) - (return-from make-instance->constructor-call nil))))) - (check-class) + (when (or (null more) + (not (constant-symbol-p key)) + (eq :allow-other-keys (constant-form-value key))) + (return-from make-instance->constructor-call nil))))) (check-args) ;; Collect a plist of initargs and constant values/parameter names ;; in INITARGS. Collect non-constant initialization forms in @@ -194,40 +364,55 @@ (loop for (key value) on args by #'cddr and i from 0 collect (constant-form-value key) into initargs if (constantp value) - collect value into initargs + collect value into initargs else - collect (parameter-name i) into initargs - and collect value into value-forms + collect (parameter-name i) into initargs + and collect value into value-forms finally - (return (values initargs value-forms))) - (let* ((class-name (constant-form-value class-name)) - (function-name (make-ctor-function-name class-name initargs - safe-code-p))) - ;; Prevent compiler warnings for calling the ctor. - (proclaim-as-fun-name function-name) - (note-name-defined function-name :function) - (when (eq (info :function :where-from function-name) :assumed) - (setf (info :function :where-from function-name) :defined) - (when (info :function :assumed-type function-name) - (setf (info :function :assumed-type function-name) nil))) - ;; Return code constructing a ctor at load time, which, when - ;; called, will set its funcallable instance function to an - ;; optimized constructor function. - `(locally - (declare (disable-package-locks ,function-name)) - (let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs - ',safe-code-p)))) - (declare (ignore .x.)) - ;; ??? check if this is worth it. - (declare - (ftype (or (function ,(make-list (length value-forms) - :initial-element t) - t) - (function (&rest t) t)) - ,function-name)) - (funcall (function ,function-name) ,@value-forms)))))))) - + (return (values initargs value-forms))) + (if (constant-class-p) + (let* ((class-or-name (constant-form-value class-arg)) + (function-name (make-ctor-function-name class-or-name initargs + safe-code-p))) + ;; Prevent compiler warnings for calling the ctor. + (proclaim-as-fun-name function-name) + (note-name-defined function-name :function) + (when (eq (info :function :where-from function-name) :assumed) + (setf (info :function :where-from function-name) :defined) + (when (info :function :assumed-type function-name) + (setf (info :function :assumed-type function-name) nil))) + ;; Return code constructing a ctor at load time, which, when + ;; called, will set its funcallable instance function to an + ;; optimized constructor function. + `(locally + (declare (disable-package-locks ,function-name)) + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-or-name ',initargs + ',safe-code-p)))) + (declare (ignore .x.)) + ;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (funcall (function ,function-name) ,@value-forms)))) + (when class-arg + ;; Build an inline cache: a CONS, with the actual cache in the CDR. + `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun. + make-instance)) + (let* ((.cache. (load-time-value (cons 'ctor-cache nil))) + (.store. (cdr .cache.)) + (.class-arg. ,class-arg)) + (multiple-value-bind (.fun. .new-store.) + (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p) + ;; Thread safe: if multiple threads hit this in paralle, the update + ;; from the other one is just lost -- no harm done, except for the + ;; need to redo the work next time. + (unless (eq .store. .new-store.) + (setf (cdr .cache.) .new-store.)) + (funcall (truly-the function .fun.) ,@value-forms)))))))))) ;;; ************************************************** ;;; Load-Time Constructor Function Generation ******* @@ -242,7 +427,10 @@ (defun install-optimized-constructor (ctor) (with-world-lock () - (let ((class (find-class (ctor-class-name ctor)))) + (let* ((class-or-name (ctor-class-or-name ctor)) + (class (if (symbolp class-or-name) + (find-class class-or-name) + class-or-name))) (unless (class-finalized-p class) (finalize-inheritance class)) ;; We can have a class with an invalid layout here. Such a class @@ -257,7 +445,10 @@ (setf (funcallable-instance-fun ctor) (multiple-value-bind (form locations names) (constructor-function-form ctor) - (apply (compile nil `(lambda ,names ,form)) locations)))))) + (apply + (let ((*compiling-optimized-constructor* t)) + (compile nil `(lambda ,names ,form))) + locations)))))) (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) @@ -688,7 +879,7 @@ ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* - when (eq (ctor-class-name ctor) name) do + when (eq (ctor-class-or-name ctor) name) do (when (ctor-class ctor) (reset (ctor-class ctor))) (loop-finish))) @@ -714,7 +905,7 @@ (defun precompile-ctors () (dolist (ctor *all-ctors*) (when (null (ctor-class ctor)) - (let ((class (find-class (ctor-class-name ctor) nil))) + (let ((class (find-class (ctor-class-or-name ctor) nil))) (when (and class (class-finalized-p class)) (install-optimized-constructor ctor)))))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index bb0b613..277416f 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -46,6 +46,27 @@ `(dotimes (,var (the fixnum ,count) ,result) (declare (fixnum ,var)) ,@body)) + +(declaim (inline random-fixnum)) +(defun random-fixnum () + (random (1+ most-positive-fixnum))) + +(defconstant n-fixnum-bits #.(integer-length most-positive-fixnum)) + +;;; Lambda which executes its body (or not) randomly. Used to drop +;;; random cache entries. +(defmacro randomly-punting-lambda (lambda-list &body body) + (with-unique-names (drops drop-pos) + `(let ((,drops (random-fixnum)) + (,drop-pos n-fixnum-bits)) + (declare (fixnum ,drops) + (type (integer 0 #.n-fixnum-bits) ,drop-pos)) + (lambda ,lambda-list + (when (logbitp (the unsigned-byte (decf ,drop-pos)) ,drops) + (locally ,@body)) + (when (zerop ,drop-pos) + (setf ,drops (random-fixnum) + ,drop-pos n-fixnum-bits)))))) ;;;; early definition of WRAPPER ;;;; @@ -102,11 +123,14 @@ (declare (type function new-value)) (aver (funcallable-instance-p fin)) (setf (funcallable-instance-fun fin) new-value)) + ;;; FIXME: these macros should just go away. It's not clear whether ;;; the inline functions defined by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS are as efficient as they could ;;; be; ordinary defstruct accessors are defined as source transforms. -(defmacro fsc-instance-p (fin) +(defun fsc-instance-p (fin) + (funcallable-instance-p fin)) +(define-compiler-macro fsc-instance-p (fin) `(funcallable-instance-p ,fin)) (defmacro fsc-instance-wrapper (fin) `(%funcallable-instance-layout ,fin)) @@ -128,7 +152,9 @@ ;;; and normal instances, so we can return true on structures also. A ;;; few uses of (OR STD-INSTANCE-P FSC-INSTANCE-P) are changed to ;;; PCL-INSTANCE-P. -(defmacro std-instance-p (x) +(defun std-instance-p (x) + (%instancep x)) +(define-compiler-macro std-instance-p (x) `(%instancep ,x)) ;; a temporary definition used for debugging the bootstrap diff --git a/src/pcl/print-object.lisp b/src/pcl/print-object.lisp index 50153b2..b5c2500 100644 --- a/src/pcl/print-object.lisp +++ b/src/pcl/print-object.lisp @@ -143,3 +143,8 @@ (defmethod print-object ((dfun-info dfun-info) stream) (declare (type stream stream)) (print-unreadable-object (dfun-info stream :type t :identity t))) + +(defmethod print-object ((ctor ctor) stream) + (print-unreadable-object (ctor stream :type t) + (format stream "~S ~:S" (ctor-class-or-name ctor) (ctor-initargs ctor))) + ctor) diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index 3d8e1b4..f7a6530 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -11,8 +11,10 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(load "test-util.lisp") + (defpackage "CTOR-TEST" - (:use "CL")) + (:use "CL" "TEST-UTIL")) (in-package "CTOR-TEST") @@ -83,5 +85,75 @@ (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2)) (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4)) + +;;; Tests for CTOR optimization of non-constant class args and constant class object args +(defun find-ctor-cache (f) + (let ((code (sb-kernel:fun-code-header f))) + (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) + for c = (sb-kernel:code-header-ref code i) + do (when (= sb-vm::value-cell-header-widetag (sb-kernel:widetag-of c)) + (let ((c (sb-vm::value-cell-ref c))) + (when (and (consp c) (eq 'sb-pcl::ctor-cache (car c))) + (return c))))))) + +(let* ((cmacro (compiler-macro-function 'make-instance)) + (opt 0) + (wrapper (lambda (form env) + (let ((res (funcall cmacro form env))) + (unless (eq form res) + (incf opt)) + res)))) + (sb-ext:without-package-locks + (unwind-protect + (progn + (setf (compiler-macro-function 'make-instance) wrapper) + (with-test (:name (make-instance :non-constant-class)) + (assert (= 0 opt)) + (let ((f (compile nil `(lambda (class) + (make-instance class :b t))))) + (assert (find-ctor-cache f)) + (assert (= 1 opt)) + (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass)))) + (with-test (:name (make-instance :constant-class-object)) + (let ((f (compile nil `(lambda () + (make-instance ,(find-class 'one-slot-subclass) :b t))))) + (assert (not (find-ctor-cache f))) + (assert (= 2 opt)) + (assert (typep (funcall f) 'one-slot-subclass)))) + (with-test (:name (make-instance :constant-non-std-class-object)) + (let ((f (compile nil `(lambda () + (make-instance ,(find-class 'structure-object)))))) + (assert (not (find-ctor-cache f))) + (assert (= 3 opt)) + (assert (typep (funcall f) 'structure-object)))) + (with-test (:name (make-instance :constant-non-std-class-name)) + (let ((f (compile nil `(lambda () + (make-instance 'structure-object))))) + (assert (not (find-ctor-cache f))) + (assert (= 4 opt)) + (assert (typep (funcall f) 'structure-object))))) + (setf (compiler-macro-function 'make-instance) cmacro)))) + +(with-test (:name (make-instance :ctor-inline-cache-resize)) + (let* ((f (compile nil `(lambda (name) (make-instance name)))) + (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+) + collect (class-name (eval `(defclass ,(gentemp) () ()))))) + (count 0) + (cache (find-ctor-cache f))) + (assert cache) + (assert (not (cdr cache))) + (dolist (class classes) + (assert (typep (funcall f (if (oddp count) class (find-class class))) class)) + (incf count) + (cond ((<= count sb-pcl::+ctor-list-max-size+) + (unless (consp (cdr cache)) + (error "oops, wanted list cache, got: ~S" cache)) + (unless (= count (length (cdr cache))) + (error "oops, wanted ~S elts in cache, got: ~S" count cache))) + (t + (assert (simple-vector-p (cdr cache)))))) + (dolist (class classes) + (assert (typep (funcall f (if (oddp count) class (find-class class))) class)) + (incf count)))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index ec38d39..5355a14 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.29.40" +"1.0.29.41"