Rev 1 version of AAAI PCL

[Gregor.pa@Xerox.COM]

I am sure this will come as a surprise to you long time PCL users, but
there are some bugs in the AAAI PCL.  This message includes patches for
the bugs that have come to my attention.  In addition, the sources on
arisia.xerox.com have been modified to include all of these patches.

Everyone using the 8/24 (beta) AAAI PCL should make these changes or
ftp a new set of files.  Because a couple of these are nasty performance
bugs, you should do this even if you haven't actually noticed a bug.

As usual, enjoy.

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

(in-package 'pcl)

;from file defsys.lisp
(defvar *pcl-system-date* "8/28/88 (beta rev 1) AAAI PCL ")

;;;
;;; There is a bug in funcallable instances in ExCL on the SUN-4.  When making
;;; this patch, be very sure to patch the correct line in the file.  There
;;; is a line which currently looks like:
;;;
;;;    (set-funcallable-instance-function new-fin #'init-fn-fun)
;;;
;;; It should look like:
;;;
;;;    (set-funcallable-instance-function new-fin #'init-fin-fun)
;;;
;;; The difference is in the spelling of the last symbol on the line.
;;;

;;;
;;; The new initialization protocol will not work when the metaclass is
;;; funcallable standard-class.
;;; 
;from fsc.lisp
(defmethod allocate-instance
	   ((class funcallable-standard-class) &rest initargs)
  (declare (ignore initargs))
  (let ((class-wrapper (class-wrapper class)))
    (allocate-funcallable-instance class-wrapper
				   (class-no-of-instance-slots class))))

;;;
;;; There is a performance bug introduced by slot-unbound checking.
;;; 

;from low.lisp
;;;
;;; This is the value that we stick into a slot to tell us that it is unbound.
;;; It may seem gross, but for performance reasons, we make this an interned
;;; symbol.  That means that the fast check to see if a slot is unbound is to
;;; say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster than looking
;;; at the value of a special variable.
;;; 
(defvar *slot-unbound* '..slot-unbound..)

;from vector.lisp
(defun std-instance-access-pv-internal
       (slots-fetcher instance pv-offset nvp new-value)
  (if nvp
      (once-only (new-value)
	`(let ((.index. (memory-block-ref .pv. ,pv-offset)))
	   (if (null .index.)
	       (pv-access-trap ,instance ,pv-offset .isl. ,new-value)
	       (setf (%svref (,slots-fetcher ,instance) .index.) ,new-value))))
      `(let ((.temp. (memory-block-ref .pv. ,pv-offset)))
	 (if (or (null .temp.)
		 (eq (setq .temp. (%svref (,slots-fetcher ,instance) .temp.))
		     ',*slot-unbound*))
	     (pv-access-trap ,instance ,pv-offset .isl.)
	     .temp.))))

;from dcode.lisp
(define-function-template all-std-class-readers-dcode
			  ()
			  '(.GENERIC-FUNCTION. .CACHE.)
  (let ()
    `(function
       (lambda (arg)
	 (locally
	   (declare (optimize (speed 3) (safety 0)))
	   (let* ((wrapper (and (iwmc-class-p arg)
				(iwmc-class-class-wrapper arg)))
		  (offset 0)
		  (val nil))
	     (if (null wrapper)
		 (no-applicable-method .GENERIC-FUNCTION. arg)
		 (progn 
		   (setq offset
			 (cache-key-from-wrappers ,generic-function-cache-size
						  2
						  wrapper))
		   (without-interrupts
		     (if (and (eq (r/w-cache-key) wrapper)
			      (neq (setq val
					 (%svref (iwmc-class-static-slots arg)
						 (r/w-cache-val)))
				   ',*slot-unbound*))
			 val					     
			 (with-interrupts 
			   (all-std-class-readers-miss
			     arg wrapper .cache.
			     ,generic-function-cache-size
			     offset .generic-function.))))))))))))

;;;
;;; There may be a performance bug with some compiler settings in some Lisps.
;;; 

;from low.lisp
(defmacro %logand (&rest args)
  `(locally (declare (optimize (speed 3) (safety 0)))
	    ,(reduce-variadic-to-binary 'logand args 0 t 'fixnum)))

(defmacro %logxor (&rest args)
  `(locally (declare (optimize (speed 3) (safety 0)))
	    ,(reduce-variadic-to-binary 'logxor args 0 t 'fixnum)))

(defmacro %+ (&rest args)
  `(locally (declare (optimize (speed 3) (safety 0)))
	    ,(reduce-variadic-to-binary '+ args 0 t 'fixnum)))

(defmacro %1+ (x)
  `(locally (declare (optimize (speed 3) (safety 0)))
	    (the fixnum (1+ (the fixnum ,x)))))

(defmacro %svref (vector index)
  `(locally (declare (optimize (speed 3) (safety 0))
		     (inline svref))
	    (svref (the simple-vector ,vector) (the fixnum ,index))))

(defsetf %svref (vector index) (new-value)
  `(locally (declare (optimize (speed 3) (safety 0))
		     (inline svref))
     (setf (svref (the simple-vector ,vector) (the fixnum ,index))
	   ,new-value)))
-------