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