Some testing showed that this commit increases instance creation throughput by 100% (ie. doubles the number of instances created in a certain amount of time.)

With this change, I was creating 1000 instances of the slot-less class A in 0.020 and 0.018 seconds. That's still way too slow: clisp does it in 0.007s but anyway, before the change it was 0.038.

Would be nice to find out how the others get their performance from - which tricks and optimizations.

Bye,

Erik.

On Sun, Feb 13, 2011 at 10:08 PM, Erik Huelsmann ehuelsmann@common-lisp.net wrote:

Author: ehuelsmann Date: Sun Feb 13 16:08:31 2011 New Revision: 13219

Log: Add caching to CHECK-INITARGS: cache sets of allowable initargs per class.

Note: This change *only* implements caching for "case 1" out of the 4 cases that check-initargs now supports. (Case 1 being instance creation.)

Modified:   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp

--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original) +++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Feb 13 16:08:31 2011 @@ -693,7 +693,8 @@   (let ((class (std-allocate-instance +the-standard-class+)))     (check-initargs (list #'allocate-instance #'initialize-instance)                     (list* class initargs)

• class t initargs)

• class t initargs
• *make-instance-initargs-cache*)

(%set-class-name name class)     (%set-class-layout nil class)     (%set-class-direct-subclasses ()  class) @@ -740,6 +741,10 @@   (list (find-class 'sequence)         (find-class 'java:java-object)))

+(defvar *make-instance-initargs-cache*

• (make-hash-table :test #'eq)
• "Cached sets of allowable initargs, keyed on the class they belong to.")

(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)   ;; Check for duplicate slots.   (remf all-keys :metaclass) @@ -786,11 +791,14 @@                     new-class))                  (t                   ;; We're redefining the class.

• (remhash old-class *make-instance-initargs-cache*)

(%make-instances-obsolete old-class)                   (setf (class-finalized-p old-class) nil)

• (check-initargs (list #'allocate-instance #'initialize-instance)

• (check-initargs (list #'allocate-instance
• #'initialize-instance)

(list* old-class all-keys)

• old-class t all-keys)

• old-class t all-keys
• nil)

(apply #'std-after-initialization-for-classes old-class all-keys)                   old-class)))           (t @@ -1585,10 +1593,31 @@                 all of the keyword arguments defined for the ~                 generic function." method-lambda-list name)))))

+(defvar *gf-initialize-instance* nil

• "Cached value of the INITIALIZE-INSTANCE generic function.

+Initialized with the true value near the end of the file.") +(defvar *gf-allocate-instance* nil

• "Cached value of the ALLOCATE-INSTANCE generic function.

+Initialized with the true value near the end of the file.") +(defvar *gf-shared-initialize* nil

• "Cached value of the SHARED-INITIALIZE generic function.

+Initialized with the true value near the end of the file.") +(defvar *gf-reinitialize-instance* nil

• "Cached value of the REINITIALIZE-INSTANCE generic function.

+Initialized with the true value near the end of the file.")

(declaim (ftype (function * method) ensure-method))  (defun ensure-method (name &rest all-keys)   (let ((method-lambda-list (getf all-keys :lambda-list))         (gf (find-generic-function name nil)))

• (when (or (eq gf *gf-initialize-instance*)
• (eq gf *gf-allocate-instance*)
• (eq gf *gf-shared-initialize*)
• (eq gf *gf-reinitialize-instance*))
• ;; ### Clearly, this can be targeted much more exact
• ;; as we only need to remove the specializing class and all
• ;; its subclasses from the hash.
• (clrhash *make-instance-initargs-cache*))

(if gf         (check-method-lambda-list name method-lambda-list                                   (generic-function-lambda-list gf)) @@ -2565,18 +2594,11 @@  ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."  ;; 7.1.2

-(defun check-initargs (gf-list args instance shared-initialize-param initargs)

• "Checks the validity of `initargs' for the generic functions in `gf-list' when

-called with `args' by calculating the applicable methods for each gf. -The applicable methods for SHARED-INITIALIZE based on `instance', -`shared-initialize-param' and `initargs' are added to the list of -applicable methods."

• (when (oddp (length initargs))
• (error 'program-error
• :format-control "Odd number of keyword arguments."))
• (unless (getf initargs :allow-other-keys)
• (let* ((methods
• (nconc

+(defun calculate-allowable-initargs (gf-list args instance

• shared-initialize-param
• initargs)
• (let* ((methods
• (nconc

(compute-applicable-methods #'shared-initialize                                          (list* instance                                                 shared-initialize-param @@ -2584,26 +2606,48 @@              (mapcan #'(lambda (gf)                          (compute-applicable-methods gf args))                      gf-list)))

• (method-keyword-args
• (reduce #'merge-initargs-sets
• (mapcar #'method-lambda-list methods)
• :key #'extract-lambda-list-keywords
• :initial-value nil))
• (slots-initargs
• (mapappend #'slot-definition-initargs
• (class-slots (class-of instance))))
• (allowable-initargs
• (merge-initargs-sets
• (merge-initargs-sets slots-initargs method-keyword-args)
• '(:allow-other-keys)))) ;; allow-other-keys is always allowed
• (unless (eq t allowable-initargs)
• (do* ((tail initargs (cddr tail))
• (initarg (car tail) (car tail)))
• ((null tail))
• (unless (memq initarg allowable-initargs)
• (error 'program-error
• :format-control "Invalid initarg ~S."
• :format-arguments (list initarg))))))))

• (method-keyword-args
• (reduce #'merge-initargs-sets
• (mapcar #'method-lambda-list methods)
• :key #'extract-lambda-list-keywords
• :initial-value nil))
• (slots-initargs
• (mapappend #'slot-definition-initargs
• (class-slots (class-of instance)))))
• (merge-initargs-sets
• (merge-initargs-sets slots-initargs method-keyword-args)
• '(:allow-other-keys))))  ;; allow-other-keys is always allowed

+(defun check-initargs (gf-list args instance

• shared-initialize-param initargs
• cache)
• "Checks the validity of `initargs' for the generic functions in `gf-list'

+when called with `args' by calculating the applicable methods for each gf. +The applicable methods for SHARED-INITIALIZE based on `instance', +`shared-initialize-param' and `initargs' are added to the list of +applicable methods."

• (when (oddp (length initargs))
• (error 'program-error
• :format-control "Odd number of keyword arguments."))
• (unless (getf initargs :allow-other-keys)
• (multiple-value-bind (allowable-initargs present-p)
• (when cache
• (gethash (class-of instance) cache))
• (unless present-p
• (setf allowable-initargs
• (calculate-allowable-initargs gf-list args instance
• shared-initialize-param initargs))
• (when cache
• (setf (gethash (class-of instance) cache)
• allowable-initargs)))
• (unless (eq t allowable-initargs)
• (do* ((tail initargs (cddr tail))
• (initarg (car tail) (car tail)))
• ((null tail))
• (unless (memq initarg allowable-initargs)
• (error 'program-error
• :format-control "Invalid initarg ~S."
• :format-arguments (list initarg))))))))

(defun merge-initargs-sets (list1 list2)   (cond @@ -2648,7 +2692,8 @@   (let ((instance (std-allocate-instance class)))     (check-initargs (list #'allocate-instance #'initialize-instance)                     (list* instance initargs)

• instance t initargs)

• instance t initargs
• *make-instance-initargs-cache*)

(apply #'initialize-instance instance initargs)     instance))

@@ -2670,7 +2715,8 @@  ;; it received."  (defmethod reinitialize-instance ((instance standard-object) &rest initargs)   (check-initargs (list #'reinitialize-instance) (list* instance initargs)

• instance () initargs)

• instance () initargs
• nil)

(apply #'shared-initialize instance () initargs))

(defun std-shared-initialize (instance slot-names all-keys) @@ -2761,7 +2807,8 @@                             (class-slots (class-of new))))))     (check-initargs (list #'update-instance-for-different-class)                     (list old new initargs)

• new added-slots initargs)

• new added-slots initargs
• nil)

(apply #'shared-initialize new added-slots initargs)))

;;; make-instances-obsolete @@ -2793,7 +2840,8 @@   (check-initargs (list #'update-instance-for-redefined-class)                   (list* instance added-slots discarded-slots                          property-list initargs)

• instance added-slots initargs)

• instance added-slots initargs
• nil)

(apply #'shared-initialize instance added-slots initargs))

;;;  Methods having to do with class metaobjects. @@ -3101,6 +3149,11 @@  ;; FIXME  (defgeneric function-keywords (method))

+(setf *gf-initialize-instance* (symbol-function 'initialize-instance)) +(setf *gf-allocate-instance* (symbol-function 'allocate-instance)) +(setf *gf-shared-initialize* (symbol-function 'shared-initialize)) +(setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance))  (setf *clos-booting* nil)

(defgeneric class-prototype (class))

---

armedbear-cvs mailing list armedbear-cvs@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs