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)))
;;; 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
:runtime-type-checks-p nil)
;;; List of all defined ctors.
-
(defvar *all-ctors* ())
(defun make-ctor-parameter-list (ctor)
;;; 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))
(setf (fdefinition function-name) ctor)
(install-initial-constructor ctor :force-p t)
ctor)))
-
+\f
+;;; *****************
+;;; 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)))))
\f
;;; ***********************************************
;;; 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 #<SOME-CLASS X> ...) 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.
(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
(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))))))))))
\f
;;; **************************************************
;;; Load-Time Constructor Function Generation *******
(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
(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))
;; 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)))
(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))))))
;;;; 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")
\f
(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))))
\f
;;;; success
projects / sbcl.git / commitdiff