[armedbear-devel] [armedbear-cvs] r13219 - trunk/abcl/src/org/armedbear/lisp

Erik Huelsmann ehuels at gmail.com
Sun Feb 13 21:00:27 UTC 2011


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 at 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 at common-lisp.net
> http://common-lisp.net/cgi-bin/mailman/listinfo/armedbear-cvs
>




More information about the armedbear-devel mailing list