From: stassats <sta...@us...> - 2016-07-10 17:56:48
|
The branch "master" has been updated in SBCL: via aeb5f66dcdac274eedb6e08cacb640e575517b55 (commit) from 93b0a4e15aed97e43a22d4cc5fdf75faf537d533 (commit) - Log ----------------------------------------------------------------- commit aeb5f66dcdac274eedb6e08cacb640e575517b55 Author: Stas Boukarev <sta...@gm...> Date: Sun Jul 10 19:59:37 2016 +0300 Optimize ALLOCATE-INSTANCE. Apply the same optimization as for MAKE-INSTANCE. --- NEWS | 1 + src/pcl/ctor.lisp | 173 +++++++++++++++++++++++++++++++++++++++++++---- src/pcl/std-class.lisp | 1 + 3 files changed, 160 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 23e2939..db64448 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,7 @@ changes relative to sbcl-1.3.7: on platforms supporting stack allocation of vectors. * optimization: improved type derivation for FIND, POSITION, COUNT, SEARCH, MISMATCH and other array and sequence functions. + * optimization: allocate-instance is now as fast as make-instance. changes in sbcl-1.3.7 relative to sbcl-1.3.6: * bug fix: preserve the name of the destructive function for the destroyed diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 98531be..97c3ecb 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -123,8 +123,10 @@ ;;; When the optimized function is computed, the function of the ;;; funcallable instance is set to it. ;;; + +;;; Type is either CTOR, for MAKE-INSTANCE, or ALLOCATOR, for ALLOCATE-INSTANCE (!defstruct-with-alternate-metaclass ctor - :slot-names (function-name class-or-name class initargs state safe-p) + :slot-names (type function-name class-or-name class initargs state safe-p) :boa-constructor %make-ctor :superclass-name function :metaclass-name static-classoid @@ -145,11 +147,15 @@ (setf (ctor-class ctor) nil (ctor-state ctor) 'initial) (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)))) + (ecase (ctor-type ctor) + (ctor + (lambda (&rest args) + (install-optimized-constructor ctor) + (apply ctor args))) + (allocator + (lambda () + (install-optimized-allocator ctor) + (funcall ctor))))))) (defun make-ctor-function-name (class-name initargs safe-code-p) (labels ((arg-name (x) @@ -178,7 +184,21 @@ ;;; Keep this a separate function for testing. (defun make-ctor (function-name class-name initargs safe-p) (without-package-locks ; for (setf symbol-function) - (let ((ctor (%make-ctor function-name class-name nil initargs nil safe-p))) + (let ((ctor (%make-ctor 'ctor function-name class-name nil initargs nil safe-p))) + (install-initial-constructor ctor :force-p t) + (push ctor *all-ctors*) + (setf (fdefinition function-name) ctor) + ctor))) + +(defun ensure-allocator (function-name class-name) + (with-world-lock () + (if (fboundp function-name) + (the ctor (fdefinition function-name)) + (make-allocator function-name class-name)))) + +(defun make-allocator (function-name class-name) + (without-package-locks ; for (setf symbol-function) + (let ((ctor (%make-ctor 'allocator function-name class-name nil nil nil nil))) (install-initial-constructor ctor :force-p t) (push ctor *all-ctors*) (setf (fdefinition function-name) ctor) @@ -354,6 +374,30 @@ (if ctor (values ctor store) (put-ctor (maybe-ctor-for-caching) store)))))) + +(defun ensure-cached-allocator (class-name store) + (flet ((maybe-ctor-for-caching () + (if (typep class-name '(or symbol class)) + (let ((name (list 'ctor 'allocator class-name))) + (ensure-allocator name class-name)) + ;; Invalid first argument: let ALLOCATE-INSTANCE worry about it. + (return-from ensure-cached-allocator + (values (lambda () + (declare (notinline allocate-instance)) + (allocate-instance class-name)) + store))))) + (if (listp store) + (multiple-value-bind (ctor list) (find-ctor class-name store) + (if ctor + (values ctor list) + (let ((ctor (maybe-ctor-for-caching))) + (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 (maybe-ctor-for-caching) store)))))) ;;; *********************************************** ;;; Compile-Time Expansion of MAKE-INSTANCE ******* @@ -373,6 +417,59 @@ (make-instance->constructor-call form (safe-code-p env))) form)) +(define-compiler-macro allocate-instance (&whole form class &rest initargs) + (or (unless (or *compiling-optimized-constructor* + initargs) + (allocate-instance->constructor-call class)) + form)) + +(defun proclaim-constructor (function-name) + ;; 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)))) + +(defun allocate-instance->constructor-call (class-arg) + (let ((constant-class (if (classp class-arg) + class-arg + (and (proper-list-of-length-p class-arg 2) + (eq (car class-arg) 'find-class) + (proper-list-of-length-p (cadr class-arg) 2) + (eq (caadr class-arg) 'quote) + (symbolp (cadadr class-arg)) + (cadadr class-arg))))) + (if constant-class + (let* ((class-or-name constant-class) + (function-name (list 'ctor 'allocator class-or-name))) + (sb-int:check-deprecated-type (if (classp class-or-name) + (class-name class-or-name) + class-or-name)) + (proclaim-constructor function-name) + ;; 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)) + (load-time-value + (ensure-allocator ',function-name ',class-or-name)) + (funcall (function ,function-name)))) + `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.)) + (let* ((.cache. (load-time-value (cons 'ctor-cache nil))) + (.store. (cdr .cache.)) + (.class-arg. ,class-arg)) + (multiple-value-bind (.fun. .new-store.) + (ensure-cached-allocator .class-arg. .store.) + ;; Thread safe: if multiple threads hit this in + ;; parallel, 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.)))))))) + (defun make-instance->constructor-call (form safe-code-p) (destructuring-bind (class-arg &rest args) (cdr form) (flet (;; @@ -413,13 +510,7 @@ (sb-int:check-deprecated-type (if (classp class-or-name) (class-name class-or-name) class-or-name)) - ;; 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))) + (proclaim-constructor function-name) ;; Return code constructing a ctor at load time, which, ;; when called, will set its funcallable instance ;; function to an optimized constructor function. @@ -492,6 +583,47 @@ locations) (ctor-state ctor) (if optimizedp 'optimized 'fallback)))))) +(defun install-optimized-allocator (ctor) + (with-world-lock () + (let* ((class-or-name (ctor-class-or-name ctor)) + (class (ensure-class-finalized + (if (symbolp class-or-name) + (find-class class-or-name) + class-or-name)))) + ;; We can have a class with an invalid layout here. Such a class + ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE + ;; ...), because part of the deal is that those only happen from + ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the + ;; class. An invalid layout of T needs to be flushed, however. + (when (eq (layout-invalid (class-wrapper class)) t) + (%force-cache-flushes class)) + (setf (ctor-class ctor) class) + (pushnew ctor (plist-value class 'allocators) :test #'eq) + (multiple-value-bind (form optimizedp) + (allocator-function-form ctor) + (setf (funcallable-instance-fun ctor) + (let ((*compiling-optimized-constructor* t)) + (handler-bind ((compiler-note #'muffle-warning)) + (compile nil form))) + (ctor-state ctor) (if optimizedp 'optimized 'fallback)))))) + +(defun allocator-function-form (ctor) + (let ((class (ctor-class ctor))) + (if (and (not (structure-class-p class)) + (not (condition-class-p class)) + (singleton-p (compute-applicable-methods #'allocate-instance + (list class))) + (every (lambda (x) + (member (slot-definition-allocation x) + '(:instance :class))) + (class-slots class))) + (values (optimizing-allocator-generator ctor) t) + (values `(lambda () + (declare #.*optimize-speed* + (notinline allocate-instance)) + (allocate-instance ,class)) + nil)))) + (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) (proto (class-prototype class)) @@ -597,7 +729,7 @@ (safe-method-qualifiers method)) when (or (and (eq :around (car qualifiers)) (not (simple-next-method-call-p method))) - (and (null qualifiers) + (and (null qualifiers) (not primary-checked-p) (not (null standard-method)) (not (eq standard-method method)))) @@ -652,6 +784,17 @@ names t)))) +(defun optimizing-allocator-generator + (ctor) + (let ((wrapper (class-wrapper (ctor-class ctor)))) + `(lambda () + (declare #.*optimize-speed*) + (block nil + (when (layout-invalid ,wrapper) + (install-initial-constructor ,ctor) + (return (funcall ,ctor))) + ,(wrap-in-allocate-forms ctor nil t))))) + ;;; Return a form wrapped around BODY that allocates an instance constructed ;;; by CTOR. EARLY-UNBOUND-MARKERS-P means slots may be accessed before we ;;; have explicitly initialized them, requiring all slots to start as diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 8c03437..3f034be 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -146,6 +146,7 @@ ;;; all. (macrolet ((def (class) `(defmethod class-prototype ((class ,class)) + (declare (notinline allocate-instance)) (with-slots (prototype) class (or prototype (setf prototype (allocate-instance class))))))) ----------------------------------------------------------------------- hooks/post-receive -- SBCL |