[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

duplicate slots in permutation vectors



(defmethod bazz2 ((foo foo))
  (with-slots (baz) foo
    (push nil baz)))

I noticed that every slot reference, even duplicates as in BAZZ2
above, are given there own position in the permutation vector.
The ISL is ((baz baz)) rather than ((baz)).

The following patch avoids duplicates by making SLOTS a nested alist:

  ((parameter (slot optimized-form ...) ...) ...)]

;;; In VECTOR.LISP
(defun sort-slots-into-isl (slots)
  ;; Returns the ISL corresponding to the SLOTS data structure build during walking a
  ;; method body.
  (let ((pv-offset -1))
    (mapcar #'(lambda (s)
		(mapcar #'(lambda (e)
			    (INCF PV-OFFSET)
			    ;; CLEVERLY SIDE EFFECT WALKED-LAMBDA.
			    (DOLIST (FORM (CDR E))
			      (SETF (SECOND (THIRD FORM)) PV-OFFSET))
			    (car e))
			(cdr s)))
	    (mapcar #'(lambda (s)
			(cons (car s)
			      (sort (cdr s)
				    #'(lambda (a b)
					(string-lessp (symbol-name (car a))
						      (symbol-name (car b)))))))
		    slots))))

(defun optimize-standard-instance-access (class parameter form slots)
  ;; Returns an optimized form corresponding to FORM.  Optimized forms are interned
  ;; on SLOTS, a nested alist, so they can be side effected later to put in their
  ;; pv-offsets.
  (destructuring-bind (ignore instance slot-name . new)
		      form
    (setq slot-name (reduce-constant slot-name))
    (let ((entry (assq parameter slots)))
      (if (null entry)
	  (error "Can't optimize instance access because there is no entry~@
                  for this class in the required parameters of this method.~@
                  There is an inconsistency in the method body optimization~@
                  data structures.  Report this as a bug.")
	  (LET ((SLOT-ENTRY (ASSQ SLOT-NAME (CDR ENTRY))))
	    (UNLESS SLOT-ENTRY
	      (PUSH (SETQ SLOT-ENTRY (LIST SLOT-NAME)) (CDR ENTRY)))
	    (LET* ((OPTIMIZED-FORM `(,(OPTIMIZE-STANDARD-INSTANCE-ACCESS-INTERNAL CLASS)
				    ,INSTANCE ',SLOT-NAME ,@NEW))
		   (INTERNED-FORM (MEMBER OPTIMIZED-FORM (CDR SLOT-ENTRY))))
	      (IF INTERNED-FORM
		  (FIRST INTERNED-FORM)
		  (PROGN (PUSH OPTIMIZED-FORM (CDR SLOT-ENTRY))
			 OPTIMIZED-FORM))))))))