[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
some fixes for Rainy Day PCL
- To: CommonLoops.PA@Xerox.COM
- Subject: some fixes for Rainy Day PCL
- From: harrisr@turing.cs.rpi.edu (Richard Harris)
- Date: Wed, 7 Mar 90 17:05:20 EST
- Redistributed: CommonLoops.PA
Here are some fixes for "2/16/90 Rainy Day PCL (beta 3)".
Rick Harris
====================
Problem: generic-functions which come from early-generic-functions are unnamed.
boot.lisp
fix-early-generic-functions
Change:
(when noisyp (format t "trampoline..."))
(fix-structure early-gf)
(when noisyp (format t "fixed..."))
! (apply #'initialize-instance early-gf default-initargs)
(dolist (early-method early-methods)
To:
(when noisyp (format t "trampoline..."))
(fix-structure early-gf)
(when noisyp (format t "fixed..."))
! (apply #'initialize-instance early-gf
! :name early-gf-spec default-initargs)
(dolist (early-method early-methods)
====================
Problem: compute-primary-cache-location dies when there are no wrappers.
cache.lisp
compute-primary-cache-location
Change:
(defun compute-primary-cache-location (field mask wrappers)
! (if (not (consp wrappers))
(logand mask (wrapper-ref wrappers field))
(let ((location 0))
To:
(defun compute-primary-cache-location (field mask wrappers)
! (if (not (listp wrappers))
(logand mask (wrapper-ref wrappers field))
(let ((location 0))
====================
Problem: raise-metatype should return T only when the specializer is T.
raise-metatype does not recognize specializers having non-standard
metaclasses.
cache.lisp
raise-metatype
Change:
(class-of (class-of (eql-specializer-object x)))
(class-of x))))
(cond ((eq x *the-class-t*) t)
! ((eq meta-specializer standard) 'standard-instance)
! ((eq meta-specializer fsc) 'standard-instance)
! ; ((eq meta-specializer structure) 'structure-instance)
! ((eq meta-specializer built-in) 'built-in-instance)
! (t 't)))))
To:
(class-of (class-of (eql-specializer-object x)))
(class-of x))))
(cond ((eq x *the-class-t*) t)
! ((*subtypep meta-specializer standard) 'standard-instance)
! ((*subtypep meta-specializer fsc) 'standard-instance)
! ; ((*subtypep meta-specializer structure) 'structure-instance)
! ((*subtypep meta-specializer built-in) 'built-in-instance)
! (t (error "PCL can not handle the specializer ~S~
! (meta-specializer ~S)" new-specializer meta-specializer))))))
====================
Problem: accessor-miss causes performance problems
Date: Mon, 26 Feb 90 11:05 PST
From: Gregor.pa@Xerox.COM
The following patch, to Rainy Day PCL, fixes a problem which, in some
programs, can cause serious performance problems. You should make this
patch right away.
dfun.lisp
accessor-miss
Change:
(cond ((null nfunction)
(no-applicable-method gf args))
((or invalidp
(null nindex))
(apply nfunction args))
To:
(cond ((null nfunction)
(no-applicable-method gf args))
+ ((null ntype)
+ (checking)
+ (apply nfunction args))
((or invalidp
(null nindex))
(apply nfunction args))
====================
Problem: Method calls without enough required arguments cause trouble.
compute-applicable-methods seems to be a good place to handle
this problem.
methods.lisp
compute-applicable-methods
Change:
(defmethod compute-applicable-methods
((generic-function generic-function) arguments)
(labels ((filter (method)
! (every #'specializer-applicable-p (method-specializers method) arguments))
(sorter (method-1 method-2)
To:
(defmethod compute-applicable-methods
((generic-function generic-function) arguments)
(labels ((filter (method)
! (let ((arguments-tail arguments))
! (dolist (m-spec (method-specializers method) t)
! (unless arguments-tail
! (error "The function ~S requires at least ~D arguments"
! (generic-function-name generic-function)
! (length (gf-arg-info generic-function))))
! (unless (specializer-applicable-p m-spec (pop arguments-tail))
! (return nil)))))
(sorter (method-1 method-2)
compute-applicable-methods
Change:
(defmethod compute-applicable-methods
((generic-function generic-function) arguments)
(labels ((filter (method)
! (every #'specializer-applicable-p (method-specializers method) arguments))
(sorter (method-1 method-2)
To:
(defmethod compute-applicable-methods
((generic-function generic-function) arguments)
(labels ((filter (method)
! (let ((arguments-tail arguments))
! (dolist (m-spec (method-specializers method) t)
! (unless arguments-tail
! (error "The function ~S requires at least ~D arguments"
! (generic-function-name generic-function)
! (length (gf-arg-info generic-function))))
! (unless (specializer-applicable-p m-spec (pop arguments-tail))
! (return nil)))))
(sorter (method-1 method-2)
init.lisp
make-instance
Change:
(compute-applicable-methods #'shared-initialize
! (list (class-prototype class)))))))
To:
(compute-applicable-methods #'shared-initialize
! (list (class-prototype class) t))))))
reinitialize-instance
Change:
(compute-applicable-methods #'shared-initialize
! (list instance))))))
To:
(compute-applicable-methods #'shared-initialize
! (list instance nil))))))
update-instance-for-different-class
Change:
(compute-applicable-methods #'shared-initialize
! (list current)))))
To:
(compute-applicable-methods #'shared-initialize
! (list current nil))))) ; nil?
update-instance-for-redefined-class
(compute-applicable-methods #'shared-initialize
! (list instance)))))
To:
(compute-applicable-methods #'shared-initialize
! (list instance added-slots)))))
====================
Problem: Uncompiled discriminating functions can cause problems.
methods.lisp
compute-discriminating-function
Change:
(defmethod compute-discriminating-function ((gf standard-generic-function))
(let* ((state (gf-dfun-state gf))
! (dfun (cond ((null state) (make-initial-dfun gf))
! ((consp state) (car state))
! (t state))))
(doctor-dfun-for-the-debugger gf dfun)))
To:
(defmethod compute-discriminating-function ((gf standard-generic-function))
(let* ((state (gf-dfun-state gf))
! (dfun (typecase state
! (null (make-initial-dfun gf))
! (function state)
! (cons (car state)))))
(doctor-dfun-for-the-debugger gf dfun)))
Change:
(defun update-dfun (generic-function dfun &optional cache)
(let ((ostate (gf-dfun-state generic-function)))
! (when (consp ostate) (free-cache (cdr ostate)))
(setf (gf-dfun-state generic-function) (if cache (cons dfun cache) dfun))
(invalidate-dfun-internal generic-function)))
To:
(defun update-dfun (generic-function dfun &optional cache)
(let ((ostate (gf-dfun-state generic-function)))
! (unless (typep ostate '(or null function)) (free-cache (cdr ostate)))
(setf (gf-dfun-state generic-function) (if cache (cons dfun cache) dfun))
(invalidate-dfun-internal generic-function)))
Change:
(defun invalidate-discriminating-function (generic-function)
(let ((ostate (gf-dfun-state generic-function)))
! (when (consp ostate) (free-cache (cdr ostate)))
(setf (gf-dfun-state generic-function) nil)
(invalidate-dfun-internal generic-function)))
To:
(defun invalidate-discriminating-function (generic-function)
(let ((ostate (gf-dfun-state generic-function)))
! (unless (typep ostate '(or null function)) (free-cache (cdr ostate)))
(setf (gf-dfun-state generic-function) nil)
(invalidate-dfun-internal generic-function)))
====================
Problem: Some compilers complain when variables declared to be of type (vector t)
are initially bound to nil.
plap.lisp
lap-reg-initial-value-form
Change:
(defun lap-reg-initial-value-form (reg)
(cond ((member reg *lap-i-regs*) 0)
! ((member reg *lap-v-regs*) nil)
((member reg *lap-t-regs*) nil)
(t
(error "What kind of register is ~S?" reg))))
To:
+ (defconstant *empty-vector* '#())
+
(defun lap-reg-initial-value-form (reg)
(cond ((member reg *lap-i-regs*) 0)
! ((member reg *lap-v-regs*) '*empty-vector*)
((member reg *lap-t-regs*) nil)
(t
(error "What kind of register is ~S?" reg))))
vector.lisp
add-pv-binding
Change:
(gather t metatypes))))
`((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
! (.PV. nil)
,@(remove nil slot-variables))
(declare ,(make-isl-type-declaration '.ISL.)
To:
(gather t metatypes))))
`((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
! (.PV. *empty-vector*)
,@(remove nil slot-variables))
(declare ,(make-isl-type-declaration '.ISL.)
====================
Problem: do-standard-defsetf-1 for KCL causes setf forms to evaluate
its arguments in the wrong order.
defs.lisp
do-standard-defsetf-1
Change:
#+kcl
(let ((helper (gensym)))
- ;;
- ;; KCL's setf macro generates better code when setf methods are
- ;; defined by (defsetf x y) than when they are defined by the
- ;; long form of defsetf or by define-setf-method.
- ;;
(setf (macro-function helper)
! #'(lambda (form env &aux (args (cdr form)))
(declare (ignore env))
! `(,setf-function-name ,(car (last args)) ,@(butlast args))))
(eval `(defsetf ,function-name ,helper)))
To:
#+kcl
(let ((helper (gensym)))
(setf (macro-function helper)
! #'(lambda (form env)
(declare (ignore env))
! (let* ((loc-args (butlast (cdr form)))
! (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))
! (vars (mapcar #'car bindings)))
! `(let ,bindings
! (,setf-function-name ,(car (last form)) ,@vars)))))
(eval `(defsetf ,function-name ,helper)))
====================