Changeset 13219


Ignore:
Timestamp:
02/13/11 21:08:31 (6 years ago)
Author:
ehuelsmann
Message:

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.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13218 r13219  
    694694    (check-initargs (list #'allocate-instance #'initialize-instance)
    695695                    (list* class initargs)
    696                     class t initargs)
     696                    class t initargs
     697                    *make-instance-initargs-cache*)
    697698    (%set-class-name name class)
    698699    (%set-class-layout nil class)
     
    740741  (list (find-class 'sequence)
    741742        (find-class 'java:java-object)))
     743
     744(defvar *make-instance-initargs-cache*
     745  (make-hash-table :test #'eq)
     746  "Cached sets of allowable initargs, keyed on the class they belong to.")
    742747
    743748(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
     
    787792                 (t
    788793                  ;; We're redefining the class.
     794                  (remhash old-class *make-instance-initargs-cache*)
    789795                  (%make-instances-obsolete old-class)
    790796                  (setf (class-finalized-p old-class) nil)
    791                   (check-initargs (list #'allocate-instance #'initialize-instance)
     797                  (check-initargs (list #'allocate-instance
     798                                        #'initialize-instance)
    792799                                  (list* old-class all-keys)
    793                                   old-class t all-keys)
     800                                  old-class t all-keys
     801                                  nil)
    794802                  (apply #'std-after-initialization-for-classes old-class all-keys)
    795803                  old-class)))
     
    15861594                generic function." method-lambda-list name)))))
    15871595
     1596(defvar *gf-initialize-instance* nil
     1597  "Cached value of the INITIALIZE-INSTANCE generic function.
     1598Initialized with the true value near the end of the file.")
     1599(defvar *gf-allocate-instance* nil
     1600  "Cached value of the ALLOCATE-INSTANCE generic function.
     1601Initialized with the true value near the end of the file.")
     1602(defvar *gf-shared-initialize* nil
     1603  "Cached value of the SHARED-INITIALIZE generic function.
     1604Initialized with the true value near the end of the file.")
     1605(defvar *gf-reinitialize-instance* nil
     1606  "Cached value of the REINITIALIZE-INSTANCE generic function.
     1607Initialized with the true value near the end of the file.")
     1608
    15881609(declaim (ftype (function * method) ensure-method))
    15891610(defun ensure-method (name &rest all-keys)
    15901611  (let ((method-lambda-list (getf all-keys :lambda-list))
    15911612        (gf (find-generic-function name nil)))
     1613    (when (or (eq gf *gf-initialize-instance*)
     1614              (eq gf *gf-allocate-instance*)
     1615              (eq gf *gf-shared-initialize*)
     1616              (eq gf *gf-reinitialize-instance*))
     1617      ;; ### Clearly, this can be targeted much more exact
     1618      ;; as we only need to remove the specializing class and all
     1619      ;; its subclasses from the hash.
     1620      (clrhash *make-instance-initargs-cache*))
    15921621    (if gf
    15931622        (check-method-lambda-list name method-lambda-list
     
    25662595;; 7.1.2
    25672596
    2568 (defun check-initargs (gf-list args instance shared-initialize-param initargs)
    2569   "Checks the validity of `initargs' for the generic functions in `gf-list' when
    2570 called with `args' by calculating the applicable methods for each gf.
     2597(defun calculate-allowable-initargs (gf-list args instance
     2598                                             shared-initialize-param
     2599                                             initargs)
     2600  (let* ((methods
     2601          (nconc
     2602             (compute-applicable-methods #'shared-initialize
     2603                                         (list* instance
     2604                                                shared-initialize-param
     2605                                                initargs))
     2606             (mapcan #'(lambda (gf)
     2607                         (compute-applicable-methods gf args))
     2608                     gf-list)))
     2609         (method-keyword-args
     2610          (reduce #'merge-initargs-sets
     2611                  (mapcar #'method-lambda-list methods)
     2612                  :key #'extract-lambda-list-keywords
     2613                  :initial-value nil))
     2614         (slots-initargs
     2615          (mapappend #'slot-definition-initargs
     2616                     (class-slots (class-of instance)))))
     2617    (merge-initargs-sets
     2618     (merge-initargs-sets slots-initargs method-keyword-args)
     2619     '(:allow-other-keys))))  ;; allow-other-keys is always allowed
     2620
     2621(defun check-initargs (gf-list args instance
     2622                       shared-initialize-param initargs
     2623                       cache)
     2624  "Checks the validity of `initargs' for the generic functions in `gf-list'
     2625when called with `args' by calculating the applicable methods for each gf.
    25712626The applicable methods for SHARED-INITIALIZE based on `instance',
    25722627`shared-initialize-param' and `initargs' are added to the list of
     
    25762631           :format-control "Odd number of keyword arguments."))
    25772632  (unless (getf initargs :allow-other-keys)
    2578     (let* ((methods
    2579             (nconc
    2580              (compute-applicable-methods #'shared-initialize
    2581                                          (list* instance
    2582                                                 shared-initialize-param
    2583                                                 initargs))
    2584              (mapcan #'(lambda (gf)
    2585                          (compute-applicable-methods gf args))
    2586                      gf-list)))
    2587            (method-keyword-args
    2588             (reduce #'merge-initargs-sets
    2589                     (mapcar #'method-lambda-list methods)
    2590                     :key #'extract-lambda-list-keywords
    2591                     :initial-value nil))
    2592            (slots-initargs
    2593             (mapappend #'slot-definition-initargs
    2594                        (class-slots (class-of instance))))
    2595            (allowable-initargs
    2596             (merge-initargs-sets
    2597              (merge-initargs-sets slots-initargs method-keyword-args)
    2598              '(:allow-other-keys)))) ;; allow-other-keys is always allowed
    2599       (unless (eq t allowable-initargs)
    2600         (do* ((tail initargs (cddr tail))
    2601               (initarg (car tail) (car tail)))
    2602              ((null tail))
    2603           (unless (memq initarg allowable-initargs)
    2604             (error 'program-error
    2605                    :format-control "Invalid initarg ~S."
    2606                    :format-arguments (list initarg))))))))
     2633    (multiple-value-bind (allowable-initargs present-p)
     2634                         (when cache
     2635                           (gethash (class-of instance) cache))
     2636       (unless present-p
     2637         (setf allowable-initargs
     2638               (calculate-allowable-initargs gf-list args instance
     2639                                             shared-initialize-param initargs))
     2640         (when cache
     2641           (setf (gethash (class-of instance) cache)
     2642                 allowable-initargs)))
     2643       (unless (eq t allowable-initargs)
     2644         (do* ((tail initargs (cddr tail))
     2645               (initarg (car tail) (car tail)))
     2646              ((null tail))
     2647              (unless (memq initarg allowable-initargs)
     2648                (error 'program-error
     2649                       :format-control "Invalid initarg ~S."
     2650                       :format-arguments (list initarg))))))))
    26072651
    26082652(defun merge-initargs-sets (list1 list2)
     
    26492693    (check-initargs (list #'allocate-instance #'initialize-instance)
    26502694                    (list* instance initargs)
    2651                     instance t initargs)
     2695                    instance t initargs
     2696                    *make-instance-initargs-cache*)
    26522697    (apply #'initialize-instance instance initargs)
    26532698    instance))
     
    26712716(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
    26722717  (check-initargs (list #'reinitialize-instance) (list* instance initargs)
    2673                   instance () initargs)
     2718                  instance () initargs
     2719                  nil)
    26742720  (apply #'shared-initialize instance () initargs))
    26752721
     
    27622808    (check-initargs (list #'update-instance-for-different-class)
    27632809                    (list old new initargs)
    2764                     new added-slots initargs)
     2810                    new added-slots initargs
     2811                    nil)
    27652812    (apply #'shared-initialize new added-slots initargs)))
    27662813
     
    27942841                  (list* instance added-slots discarded-slots
    27952842                         property-list initargs)
    2796                   instance added-slots initargs)
     2843                  instance added-slots initargs
     2844                  nil)
    27972845  (apply #'shared-initialize instance added-slots initargs))
    27982846
     
    31023150(defgeneric function-keywords (method))
    31033151
     3152
     3153(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
     3154(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
     3155(setf *gf-shared-initialize* (symbol-function 'shared-initialize))
     3156(setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance))
    31043157(setf *clos-booting* nil)
    31053158
Note: See TracChangeset for help on using the changeset viewer.