[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
88/8/1 PCL patches
- To: CommonLoops.pa@Xerox.COM
- Subject: 88/8/1 PCL patches
- From: kanderso@WILMA.BBN.COM
- Date: Tue, 02 Aug 88 17:28:50 -0400
- Cc: kanderson@WILMA.BBN.COM
- Redistributed: CommonLoops.pa
Gregor,
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".
#||
Questions:
? 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.
BUGS:
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.
#+patched-in-sources
(defmacro generic-function-cache-offset (mask &rest classes)
(let ((cache-numbers (mapcar #'(lambda (class)
`(the fixnum (object-cache-no ,class ,mask))) ; JL
classes)))
(if (cdr cache-numbers)
`(logand ,mask (logxor ,@cache-numbers))
`(logand ,mask ,@cache-numbers))))
#+patched-in-sources
(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.
#+lispm
#+patched-in-sources
(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)
object
slot-name
&optional dont-call-slot-missing-p
default)
(if (member class *changing-classes* :test #'eq)
(call-next-method)
(progn
(let ((*changing-classes* (cons class *changing-classes*)))
(change-class object
(cadr (slot-value class 'class-precedence-list))))
(slot-value-using-class
(class-of object) object slot-name dont-call-slot-missing-p default))))
;;;
;;; Patch LOW.LISP
;;; Jim Larus speed up for stock hardware.
#+patched-in-sources
(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)
,.wrappers))
((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).
#+patched-in-sources
(defmacro %logand (&rest args)
(cond ((null args) `(logand))
((cdr args) `(logand .,args))
(t (car args)))) ; JL
#+patched-in-sources
(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.
;;;
;;; Patch METHODS.LISP
;;; 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,
INITIALIZE-FROM-INIT-PLIST, INITIALIZE-FROM-DEFAULTS, etc., defined on
all classes.
||#
#+patched-in-sources
(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))
(cond
((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-cache-cache-entry
wrapper
(class-wrapper-slot-value-offset wrapper ,slot-name)
,slot-name
,temp1))
(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)))
(let
(,@(and (caar dynamic-case) `((,(caar dynamic-case) ,temp1)))
,@(and (cadar dynamic-case) `((,(cadar dynamic-case)
,createp-var))))
(return . ,(cdr dynamic-case))))
nil-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
dont-call-slot-missing-p
default)
(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))
DEFAULT))))
;;; recompile
(defun put-slot-using-class--class-internal (class object slot-name new-value
dont-call-slot-missing-p)
(with-slot-internal--class
(class object slot-name dont-call-slot-missing-p)
(:instance (index) (setf (get-static-slot--class object index)
new-value))
(: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)))
;;;
;;; Patch STD-CLASS.LISP
;;; KRA: Eliminate need for class-direct-generic-functions.
#+patched-in-sources
(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))
gfs))
;;; This is what i want, but i can't pull it through the metabraid.
#+patched-in-sources
(defmethod-setf class-direct-methods ((class standard-class)) (nv)
(put-slot--class class 'direct-methods nv))
;;;
;;; Patch STD-CLASS.LISP
;;; 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)
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)
instance-slots)))
(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*
(FUNCTION-NAME-FOR-DEBUGGER FRAME))
;; 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))