From ab7aedfb1e4c0245814beb998e74e099b71092a6 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 19 Jul 2010 06:34:36 +0000 Subject: [PATCH] 1.0.40.3: better non-ctor make-instance Actually, the really expensive bit is the initarg validity checking. Use the ctor machinery to cache the results of testing for initarg validity for make-instance as well as reinitialize-instance. (Why wasn't this done before?) With this change, asdf.fasl loads about 10% faster. --- NEWS | 7 +++++-- src/pcl/ctor.lisp | 33 +++++++++++++++++++++++++++++---- src/pcl/init.lisp | 13 ++----------- tests/clos.impure.lisp | 30 +++++++++++++++++++++++++++++- version.lisp-expr | 2 +- 5 files changed, 66 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 5877845..401be82 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- -changes in sbcl-1.0.41 relative to sbcl-1.0.40: - * bug fix: WRITE always returns the correct value +changes relative to sbcl-1.0.40: + * optimization: validity of observed keyword initargs to MAKE-INSTANCE is + cached, leading to many fewer expensive calls to + COMPUTE-APPLICABLE-METHODS. + * bug fix: WRITE always returns the correct value. changes in sbcl-1.0.40 relative to sbcl-1.0.39: * bug fix: readdir now works on :inode64 darwin builds (lp#592897) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 9bcfbd8..6f703ad 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -908,14 +908,15 @@ ;;; ******************************* (defun update-ctors (reason &key class name generic-function method) - (labels ((reset (class &optional ri-cache-p (ctorsp t)) + (labels ((reset (class &optional initarg-caches-p (ctorsp t)) (when ctorsp (dolist (ctor (plist-value class 'ctors)) (install-initial-constructor ctor))) - (when ri-cache-p - (setf (plist-value class 'ri-initargs) ())) + (when initarg-caches-p + (dolist (cache '(mi-initargs ri-initargs)) + (setf (plist-value class cache) ()))) (dolist (subclass (class-direct-subclasses class)) - (reset subclass ri-cache-p ctorsp)))) + (reset subclass initarg-caches-p ctorsp)))) (ecase reason ;; CLASS must have been specified. (finalize-inheritance @@ -961,6 +962,30 @@ (when (and class (class-finalized-p class)) (install-optimized-constructor ctor)))))) +;;; FIXME: CHECK-FOO-INITARGS share most of their bodies. +(defun check-mi-initargs (class initargs) + (let* ((class-proto (class-prototype class)) + (keys (plist-keys initargs)) + (cache (plist-value class 'mi-initargs)) + (cached (assoc keys cache :test #'equal)) + (invalid-keys + (if (consp cached) + (cdr cached) + (let ((invalid + (check-initargs-1 + class initargs + (list (list* 'allocate-instance class initargs) + (list* 'initialize-instance class-proto initargs) + (list* 'shared-initialize class-proto t initargs)) + t nil))) + (setf (plist-value class 'mi-initargs) + (acons keys invalid cache)) + invalid)))) + (when invalid-keys + ;; FIXME: should have an operation here, and maybe a set of + ;; valid keys. + (error 'initarg-error :class class :initargs invalid-keys)))) + (defun check-ri-initargs (instance initargs) (let* ((class (class-of instance)) (keys (plist-keys initargs)) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 7e59506..27342bd 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -34,17 +34,8 @@ (when class-default-initargs (setf initargs (default-initargs initargs class-default-initargs))) (when initargs - (when (and (eq **boot-state** 'complete) - (not (getf initargs :allow-other-keys))) - (let ((class-proto (class-prototype class))) - (check-initargs-1 - class initargs - (append (compute-applicable-methods - #'allocate-instance (list class)) - (compute-applicable-methods - #'initialize-instance (list class-proto)) - (compute-applicable-methods - #'shared-initialize (list class-proto t))))))) + (when (eq **boot-state** 'complete) + (check-mi-initargs class initargs))) (let ((instance (apply #'allocate-instance class initargs))) (apply #'initialize-instance instance initargs) instance))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 91eab01..e08f7a7 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1833,5 +1833,33 @@ "ok!")) (invoke-restart r)))))) (no-primary-method/retry (cons t t)))))) - + +;;; test that a cacheing strategy for make-instance initargs checking +;;; can handle class redefinitions +(defclass cacheing-initargs-redefinitions-check () + ((slot :initarg :slot))) +(defun cacheing-initargs-redefinitions-check-fun (&optional (initarg :slot)) + (declare (notinline make-instance)) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check initarg 3)) +(with-test (:name :make-instance-initargs) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check :slot 3) + (cacheing-initargs-redefinitions-check-fun :slot) + (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot2)))) +(defclass cacheing-initargs-redefinitions-check () + ((slot :initarg :slot2))) +(with-test (:name :make-instance-redefined-initargs) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check :slot2 3) + (cacheing-initargs-redefinitions-check-fun :slot2) + (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot)))) +(defmethod initialize-instance :after ((class cacheing-initargs-redefinitions-check) &key slot) + nil) +(with-test (:name :make-instance-new-method-initargs) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check :slot2 3) + (cacheing-initargs-redefinitions-check-fun :slot2) + (let ((thing (cacheing-initargs-redefinitions-check-fun :slot))) + (assert (not (slot-boundp thing 'slot))))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index ef0661d..d07ced6 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.40.2" +"1.0.40.3" -- 1.7.10.4