From 386e90a63e7f9587f7c4d6b9206da72b16dc1361 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 26 Jun 2009 20:45:04 +0000 Subject: [PATCH] 1.0.29.48: compute default initargs for SB-PCL::FAST-MAKE-INSTANCE MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit * Reported by Lars Rune Nøstdal. * SB-PCL::DEFAULT-INITARGS doesn't have to be a generic function. * Test-case. --- NEWS | 8 ++++---- src/pcl/ctor.lisp | 9 ++++++--- src/pcl/generic-functions.lisp | 2 -- src/pcl/init.lisp | 6 ++---- src/pcl/time.lisp | 4 ++-- tests/ctor.impure.lisp | 31 +++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 46 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index d6ec6ff..c1d2e37 100644 --- a/NEWS +++ b/NEWS @@ -15,10 +15,10 @@ with a specialised code sequence. * optimization: MAKE-INSTANCE with non-constant class-argument but constant keywords is an order of magnitude faster. - * optimization: MAKE-INSTANCE with constant keyword arguments is somewhat - faster for non-standard metaclass classes as long as there are no methods - additional on MAKE-INSTANCE and initialization arguments can be validated - at compile-time. + * optimization: MAKE-INSTANCE with constant keyword arguments is x2-4 faster + in the presence of :AROUND or non-standard primary INITIALIZE-INSTANCE + methods, and similarly for non-standard metaclass classes as long as there + are no methods additional on MAKE-INSTANCE. * 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/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index d330833..6a81d8c 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -562,9 +562,12 @@ ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around compilation of ;; the constructor, hence avoiding the possibility of endless recursion. (make-instance ,class ,@initargs)) - `(lambda ,lambda-list - (declare #.*optimize-speed*) - (fast-make-instance ,class ,@initargs))))) + (let ((defaults (class-default-initargs class))) + (when defaults + (setf initargs (default-initargs initargs defaults))) + `(lambda ,lambda-list + (declare #.*optimize-speed*) + (fast-make-instance ,class ,@initargs)))))) ;;; Not as good as the real optimizing generator, but faster than going ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs. diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 7428801..4439b02 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -391,8 +391,6 @@ (defgeneric compute-slot-accessor-info (slotd type gf)) -(defgeneric default-initargs (class initargs defaults)) - (defgeneric find-method-combination (generic-function type options)) (defgeneric invalid-qualifiers (generic-function combin method)) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 62a342f..a4c3dad 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -32,7 +32,7 @@ (unless (class-finalized-p class) (finalize-inheritance class)) (let ((class-default-initargs (class-default-initargs class))) (when class-default-initargs - (setf initargs (default-initargs class initargs 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))) @@ -49,9 +49,7 @@ (apply #'initialize-instance instance initargs) instance))) -(defmethod default-initargs ((class slot-class) - supplied-initargs - class-default-initargs) +(defun default-initargs (supplied-initargs class-default-initargs) (loop for (key nil fun) in class-default-initargs when (eq (getf supplied-initargs key '.not-there.) '.not-there.) append (list key (funcall fun)) into default-initargs diff --git a/src/pcl/time.lisp b/src/pcl/time.lisp index b7a4e95..6f21f7c 100644 --- a/src/pcl/time.lisp +++ b/src/pcl/time.lisp @@ -75,8 +75,8 @@ (push (cons "Time default-initargs." '(time-default-initargs (find-class 'plist-mixin) 1000)) *tests*) -(defun time-default-initargs (class n) - (time (dotimes-fixnum (i n) (default-initargs class nil)))) +(defun time-default-initargs (n) + (time (dotimes-fixnum (i n) (default-initargs nil nil)))) (push (cons "Time make-instance." '(time-make-instance (find-class 'plist-mixin) 1000)) diff --git a/tests/ctor.impure.lisp b/tests/ctor.impure.lisp index f7a6530..0fda4eb 100644 --- a/tests/ctor.impure.lisp +++ b/tests/ctor.impure.lisp @@ -96,6 +96,19 @@ (when (and (consp c) (eq 'sb-pcl::ctor-cache (car c))) (return c))))))) +;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this +;;; as well. +(defun find-callee (f &key (type t) (name nil namep)) + (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun 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 (typep c 'sb-impl::fdefn) + (let ((fun (sb-impl::fdefn-fun c))) + (when (and (typep fun type) + (or (not namep) + (equal name (sb-impl::fdefn-name c)))) + (return fun))))))) + (let* ((cmacro (compiler-macro-function 'make-instance)) (opt 0) (wrapper (lambda (form env) @@ -155,5 +168,23 @@ (dolist (class classes) (assert (typep (funcall f (if (oddp count) class (find-class class))) class)) (incf count)))) + +;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs +(defclass some-class () + ((aroundp :initform nil :reader aroundp)) + (:default-initargs :x :success?)) +(defmethod initialize-instance :around ((some-class some-class) &key (x :fail?)) + (unless (eq x :success?) + (error "Default initarg lossage")) + (setf (slot-value some-class 'aroundp) t) + (when (next-method-p) + (call-next-method))) +(with-test (:name (make-instance :ctor-default-initargs)) + (assert (aroundp (eval `(make-instance 'some-class)))) + (let ((fun (compile nil `(lambda () (make-instance 'some-class))))) + (assert (aroundp (funcall fun))) + ;; make sure we tested what we think we tested... + (let ((ctor (find-callee fun :type 'sb-pcl::ctor))) + (assert (find-callee ctor :name 'sb-pcl::fast-make-instance))))) ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 1246f7b..2d13684 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.47" +"1.0.29.48" -- 1.7.10.4