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

88/8/1 PCL patches

Here are the remaining patches i've had to make to get the latest PCL
to run through my test cases.

Basicially they cover:

1.  Jim Larus' performance improvements.
2.  Class redefinition infinite loop.
3.  Angela Dappert-Farquhar's with-slots-internal--class and related function.
4.  Eliminate need for class-direct-generic-functions.
5.  Fix some differences between 7-1 and 7-2 debugger.

I realize, you plan to rework some of these, but 2 & 3 are needed to
make PCL useable now.

;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp; Patch-File: Yes -*-

;;; Patches to "8/1/88 (beta) Laguna Seca PCL"
;;; Patches that must be made in the sources files are commented out here with
;;; "#+patched-in-sources".



? Why does make-parameter-references produce a warning?

? Can the logand's and logxor's in dcode be replaced by %logand and %logxor?

? Should the debugger ignore more internal functions?

To Do:

o mki -> make-instance.

o Remove extra defmethod print-object in methods.lisp

o add ignore declarations to keep compiler quiet.

o Fix iterate compiler problem in 7.1

o extend Jim larus's fixnum patch to pair logand arguments for
  machines that only optimize binary arguments.


o specializer (eql fred) works but (eql 'fred) as in CLOS doesn't.

o supress lispm's redefinition warnings for setf methods.

o C-E in debugger or M-. on a method can't find it unless it has been ZMAC'd

o tracing methods doesn't work

(in-package 'pcl)

;;; Patch DCODE.LISP
;;; 2.  The following changes (marked with JL) force a few more critical
;;; operations to be open-coded.
(defmacro generic-function-cache-offset (mask &rest classes)
  (let ((cache-numbers (mapcar #'(lambda (class)
				   `(the fixnum (object-cache-no ,class ,mask))) ; JL
    (if (cdr cache-numbers)
	`(logand ,mask (logxor ,@cache-numbers))
	`(logand ,mask ,@cache-numbers))))

(defmacro generic-function-cache-entry (cache offset offset-from-offset)
  `(memory-block-ref ,cache (+ (the fixnum ,offset) ; JL
			       (the fixnum ,offset-from-offset)))) ; JL

;;; Patch FIXUP.LISP
;;; Avoid warning.
(si:allow-redefinition 'print-iwmc-class 'defun)
;;; Patch HIGH.LISP
;;; Class redefinition infinite loop.
(defvar *changing-classes* () "Stack of changing classes.")

(defmethod slot-value-using-class ((class obsolete-class)
				   &optional dont-call-slot-missing-p
  (if (member class *changing-classes* :test #'eq)
	(let ((*changing-classes* (cons class *changing-classes*)))
	  (change-class object
			(cadr (slot-value class 'class-precedence-list))))
	  (class-of object) object slot-name dont-call-slot-missing-p default))))

;;; Patch LOW.LISP
;;; Jim Larus speed up for stock hardware.
(defmacro cache-key-from-wrappers
	  ((size words-per-entry &optional (op 'logxor)) &rest wrappers)
  (when (or (not (numberp size))
	    (not (numberp words-per-entry)))
    (error "Using cache-key-from-wrappers improperly.~@
            The size and words-per-entry arguments must be unquoted numbers."))
  (when (not (member op '(nil logand logxor)))
    (error "Using cache-key-from-wrappers improperly.~@
            If supplied, the op argument must be an unquoted symbol, and~@
            one of LOGAND and LOGXOR."))
  ;; Convert the wrapper forms into forms which will fetch the wrapper's
  ;; cache number.  That is what we really need to work with.
  (setq wrappers (mapcar #'(lambda (w) `(the fixnum (wrapper-cache-no ,w)))
			 wrappers)) ; JL
  (cond ((and (null (cdr wrappers)) (= size 2))
	 (car wrappers))
	((eq op 'logand)
	 `(%logand ,(make-memory-block-mask size words-per-entry)
	((eq op 'logxor)
	 `(%logand ,(make-memory-block-mask size words-per-entry)
		   (%logxor ,.wrappers)))))

;;; Patch LOW.LISP
;;; 3.  Finally, the following two macros (add to excl-low.lisp) optimize
;;; the trivial cases of a couple of operations.  Yes, the compiler should
;;; do this.  Yes, the one arg case does occur in practice (in fact, in
;;; the discriminator code for methods with a single discriminated
;;; argument).

(defmacro %logand (&rest args)
  (cond ((null args) `(logand))
	((cdr args) `(logand .,args))
	(t (car args))))		; JL

(defmacro %logxor (&rest args)
  (cond ((null args) `(logxor))
	((cdr args) `(logxor .,args))
	(t (car args))))		; JL

;;;	I don't have performance numbers for the latter two
;;; optimizations, but I remember that they were on the order of a 20%
;;; reduction in the execution time for Curare.

;;; Jim Larus' 20% speedup.
1.  Increase the size of the constant GENERIC-FUNCTION-CACHE-SIZE from
32 to 64 (methods.lisp).  This decreased the execution time of Curare
by 20-33%.  In one test, the number of calls on PCL::LOOKUP-METHOD-INTERNAL
(i.e., the cache-miss code) fell from 5224 to 1335.  Interestingly,
most of these calls came from built-in methods, mainly INITIALIZE,
all classes.
(defconstant generic-function-cache-size 64)
;;; Patch SLOTS.LISP
;;; From: Angela Dappert-Farquhar <unido!ztivax!adf@uunet.uu.net>
(defmacro with-slot-internal--class ((class object slot-name createp)
				     &body cases)
  (let ((temp1 (gensym))
        (temp2 (gensym))
        (createp-var (gensym))
        (instance-case (cdr (assq :instance cases)))
        (dynamic-case (cdr (assq :dynamic cases)))
        (class-case (cdr (assq :class cases)))
        (nil-case (cdr (assq nil cases))))
    `(prog (,temp1                              ;The Horror! Its a PROG,
            ,temp2                              ;but its in a macro so..
            (,createp-var ,createp))
           ((setq ,temp1 (slotd-position ,slot-name
					 (class-instance-slots ,class)))
            ;; We have the slots position in the instance slots.  Convert
	    ;; that to the slots index and then cache the index and return
	    ;; the result of evaluating the instance-case.
            (setq ,temp1 (%convert-slotd-position-to-slot-index ,temp1))
            (let ((wrapper (validate-class-wrapper ,object)))
                (class-wrapper-slot-value-offset wrapper ,slot-name)
            (return (let ,(and (car instance-case)
			       `((,(caar instance-case) ,temp1)))
                      . ,(cdr instance-case))))
           ((setq ,temp1 (find-slotd ,slot-name
				     (class-non-instance-slots ,class)))
            ;; We have a slotd -- this is some sort of declared slot.
            (ecase (slotd-allocation ,temp1)
              (:class      (return
                             (let ,(and (car class-case)
                                        `((,(caar class-case) ,temp1)))
                               . ,(cdr class-case))))
              ((:none nil) (go nil-case))
              (:dynamic    (setq ,createp-var :dynamic
                                 ,temp2       (slotd-initform ,temp1))))))
         ;; When we get here, either:
         ;;  - we didn't find a slot-description for this slot, so try to
         ;;    find it in the dynamic slots creating it if createp-var is
         ;;    non-null.
         ;;  - we found a :dynamic slot-description, createp-var got set
         ;;    to :dynamic and we dropped through to here where we try
         ;;    to find the slot.  If we find it we return the loc.  If
         ;;    not we create it and initialize it to its default value.
         (multiple-value-setq (,temp1 ,createp-var)
           (dynamic-slot-loc--class ,object ,slot-name ,createp-var))
         (when ,temp1
           (when (and ,createp-var ,temp2)
             (setf (car ,temp1) (eval ,temp2)))
             (,@(and (caar dynamic-case) `((,(caar dynamic-case) ,temp1)))
              ,@(and (cadar dynamic-case) `((,(cadar dynamic-case)
             (return . ,(cdr dynamic-case))))
         ;; This slot is either explicitly declared :allocation nil (we
         ;; jumped here by (GO NIL-CASE) or there is no declaration for
         ;; this slot and we didn't find it in the dynamic-slots, we fell
         ;; through from the dynamic lookup above.
         (let ,(and (car nil-case) `((,(caar nil-case) ,temp1)))
           (RETURN . ,(cdr nil-case))))))

;;; Patch and recompile
(defun slot-value-using-class--class-internal (class object slot-name
  (with-slot-internal--class (class object slot-name nil)
    (:instance (index) (get-static-slot--class object index))
    (:dynamic (loc newp) (if (eq newp t) (setf (car loc) default) (car loc)))
    (:class (slotd) (slotd-initform slotd))
    (nil () (PROGN
	      (unless dont-call-slot-missing-p
		(slot-missing object slot-name))

;;; recompile
(defun put-slot-using-class--class-internal (class object slot-name new-value
	  (class object slot-name dont-call-slot-missing-p)
    (:instance (index) (setf (get-static-slot--class object index)
    (:dynamic (loc) (setf (car loc) new-value))
    (:class (slotd) (setf (slotd-initform slotd) new-value))
    (nil () (unless dont-call-slot-missing-p
	      (slot-missing object slot-name)))))

;;; Recompile
(defmethod slot-allocation-using-class ((class standard-class) object slot-name)
  (with-slot-internal--class (class object slot-name nil)
    (:instance () :instance)
    (:dynamic () :dynamic)
    (:class () :class)
    (nil    () nil)))

;;; KRA: Eliminate need for class-direct-generic-functions.
(defmethod update-method-inheritance ((class standard-class) old-cpl new-cpl)
  (declare (ignore class))
  (unless (eq old-cpl new-cpl)
    (dolist (old old-cpl)
      (unless (member old new-cpl)
	(dolist (old-gf (class-direct-methods old))
	  (invalidate-generic-function (method-generic-function old-gf)))))
    (dolist (new new-cpl)
      (unless (member new old-cpl)
	(dolist (new-gf (class-direct-methods new))
	  (if (null (method-generic-function new-gf)) 
	      ;; There are occasional methods with null generic-function slots.  
	      ;; Report if you find one.
	      (print (list 'REPORT-BUG-TO-KEN new-gf))
	      (invalidate-generic-function (method-generic-function new-gf))))))))

;;; For anyone that needs it.
(defmethod class-direct-generic-functions ((class standard-class))
  (let ((gfs ()))
    (map 'nil #'(lambda (m) (pushnew (method-generic-function m) gfs)) 
	 (class-direct-methods class))

;;; This is what i want, but i  can't pull it through the metabraid.
(defmethod-setf class-direct-methods ((class standard-class)) (nv)
  (put-slot--class class 'direct-methods nv))

;;; part of class redefintion bug.
(defun update-slots--class (class)
  (let* ((cpl (class-precedence-list class))
	 (obsolete-class nil)
	 (local-slots (class-local-slots class))
	 (slots ())
	 (instance-slots ())
	 (non-instance-slots ()))

    ;; If I saved accessor/reader prefixes somewhere, I could save time
    ;; here.  Also, if merge actually kept track of whether something
    ;; changed that would save time.
    (merge-accessor/reader-prefixes local-slots (class-options class))
    (check-accessor/reader-compatibility local-slots)

    (setq slots (order-slotds class
			      (collect-slotds class local-slots cpl)
    (dolist (slot slots)
      (if (eq (slotd-allocation slot) ':instance)
	  (push slot instance-slots)
	  (push slot non-instance-slots)))
    (setq instance-slots (reverse instance-slots)
	  non-instance-slots (reverse non-instance-slots))

    (update-slot-accessors--class class instance-slots non-instance-slots)
    ;; If there is a change in the shape of the instances then the
    ;; old class is now obsolete.  Make a copy of it, then fill
    ;; ourselves in properly and obsolete it.
    (when (and (class-has-instances-p class)
	       (not (same-shape-slots-p (class-instance-slots class)
      (setq obsolete-class (copy-class class)))
    (setf (class-no-of-instance-slots class) (length instance-slots))
    (setf (class-instance-slots class) instance-slots)
    (setf (class-non-instance-slots class) non-instance-slots)
    (when obsolete-class
      (flush-class-caches class)
      (make-class-obsolete class obsolete-class))))
;;;      (make-class-obsolete class (copy-class class))))) ; KRA: BUG?

;;; Patch 7DEBUG.LISP
;;; Fix differences between 7-1 and 7-2.
(in-package 'debugger)
(defun show-all-compiled-7-1 (&optional show-source-file-p)
  (let* ((*printing-monitor-message* t)
	 (frame *current-frame*)
	 (function (frame-function frame)))
    (format t "~V~S~" *emphasis-character-style* (function-name-for-debugger frame))
    (when show-source-file-p
      (print-function-source-file function))
    (format t "~2%")
    ;; Print the arguments, including the rest-arg which is a local
    (let ((local-start (print-frame-args *current-frame* 1 t)))
      (cond ((frame-active-p *current-frame*)
	     ;; Print the rest of the locals, if the frame is active
	     (print-frame-locals *current-frame* local-start 1)
	     (format t "~%~VDisassembled code:~" *deemphasis-character-style*)
	     (show-all-compiled-1 frame function)
	     ;; This kludge is to prevent the prompt from triggering a **MORE**
	     ;; when it comes out on the bottom line of the window
	     (if (memq :notice (send standard-output :which-operations))
		 (send standard-output :notice :input-wait)))))))

(defun show-all-compiled-7-2 (&optional show-source-file-p)
  (let* ((*printing-monitor-message* t)
	 (frame *current-frame*)
	 (function (frame-function frame)))
    (format t "~V~S~" *emphasis-character-style*
			;; KRA: (lframe-function-name *current-language* function nil))
    (when show-source-file-p
      (print-function-source-file function))
    (format t "~2%")
    ;; Print the arguments, including the rest-arg which is a local
    (let ((local-start (print-frame-args *current-frame* 1 t)))
      (cond ((frame-active-p frame)
	     ;; Print the rest of the locals, if the frame is active
	     (print-frame-locals frame local-start 1)
	     (lframe-show-code-for-function *current-language* frame function
					    (lframe-show-source-code-p *current-language*)
					    :brief nil)
	     ;; This kludge is to prevent the prompt from triggering a **MORE**
	     ;; when it comes out on the bottom line of the window
	     (when (memq :notice (send standard-output :which-operations))
	       (send standard-output :notice :input-wait)))))))

(defun genera-7-2-p () (cl:member :genera-release-7-2 cl:*features*))

(cl:setf (cl:symbol-function 'show-all-compiled)
      (if (genera-7-2-p) #'show-all-compiled-7-2 #'show-all-compiled-7-1))