Re: PCL benchmark

[Stan Lanning <Lanning.pa@Xerox.COM>]

I raised the point about CLOS v PCL because the original note slammed CLOS,
not PCL.  The CLOS committee went to great pains to make sure that CLOS was
*effeciently* implementable, even on stock hardware.  From what I have
heard, they succeeded.  My worry is that CLOS may get an undeserved bad
reputation, based on stories that start out "CLOS is *slow*; I ran this
test in PCL and...".

In fact, even giving PCL a bad rep is undeserved.  To complain that the
current version (or worse, some past version) is slow compared to some more
mature code is unfair.  Might as well complain that it isn't much good at
generating reports, esp. compared to COBOL.

So let's remember:  PCL is not CLOS, and PCL is not anywhere near done.


----- smL

e wrapper static-slots sxhash slot-name)
  `(let ((offset (%logand slot-value-cache-mask
			  (%logxor (validate-wrapper ,instance ,wrapper)
				   ,sxhash)))
	 (cache *slot-value-cache*)
	 (pos 0))
     (declare (fixnum offset pos))
     (without-interrupts
       (if (and (eq (%svref cache offset) ,wrapper)
		(eq (%svref cache (%+ offset 1)) ,slot-name))
	   (progn
	     (setq pos (%svref cache (%+ offset 2)))
	     (with-interrupts
	       (get-slot-value-2
		 ,instance ,wrapper ,slot-name ,static-slots pos)))
	   (with-interrupts
	     (get-slot-value-cache-miss
	       ,instance ,wrapper ,static-slots ,slot-name offset))))))

(defmacro set-slot-value-1 (nv instance wrapper static-slots sxhash slot-name)
  `(let ((offset (%logand slot-value-cache-mask
			  (%logxor (validate-wrapper ,instance ,wrapper)
				   ,sxhash)))
	 (cache *slot-value-cache*)
	 (pos 0))
    (declare (fixnum offset pos))
     (without-interrupts
       (if (and (eq (%svref cache offset) ,wrapper)
		(eq (%svref cache (%+ offset 1)) ,slot-name))
	   (progn
	     (setq pos (%svref cache (%+ offset 2)))
	     (with-interrupts
	       (set-slot-value-2
		 ,nv ,instance ,wrapper ,slot-name ,static-slots pos)))
	  (with-interrupts
	    (set-slot-value-cache-miss
	      ,nv ,instance ,wrapper ,static-slots ,slot-name offset))))))

(defmacro slotd-position (slotd-name slotds)
  `(let ((slotd-name ,slotd-name))
     (do ((pos 0 (+ pos 1))
	  (slotds ,slotds (cdr slotds)))
	 ((null slotds) nil)
       (declare (type #-kcl integer #+kcl fixnum pos) (type list slotds))
       (and (eq slotd-name (slotd-name (car slotds)))
	    (return pos)))))

;in dcode
(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))
	     (declare (type #-kcl integer #+kcl fixnum offset))
	     (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.))))))))))))

(define-function-template all-std-class-writers-dcode
			  ()
			  '(.GENERIC-FUNCTION. .CACHE.)
  (let ()
    `(function
       (lambda (new-value arg)
	 (locally
	   (declare (optimize (speed 3) (safety 0)))
	   (let* ((wrapper (and (iwmc-class-p arg)
				(iwmc-class-class-wrapper arg)))
		  (offset 0))
	     (declare (type #-kcl integer #+kcl fixnum offset))
	     (if (null wrapper)
		 (no-applicable-method .GENERIC-FUNCTION. new-value arg)
		 (progn
		   (setq offset
			 (cache-key-from-wrappers ,generic-function-cache-size
						  2
						  wrapper))
		   (without-interrupts
		     (if (eq (r/w-cache-key) wrapper)
			 (setf (%svref (iwmc-class-static-slots arg)
				       (r/w-cache-val))
			       new-value)
			 (with-interrupts 
			   (all-std-class-writers-miss
			     new-value arg wrapper .cache.
			     ,generic-function-cache-size
			     offset .generic-function.))))))))))))

(define-function-template caching-discriminating-function
                          (required restp specialized-positions cache-size)
                          '(.GENERIC-FUNCTION. .CACHE.)
  (let* ((nspecialized				;the number of specialized
						;arguments
	   (length specialized-positions))
	 (line-size				;the number of elements in
						;a line of the cache
	   (+ nspecialized 1))
	 (args
	   (gathering ((args (collecting)))
	     (dotimes (i required)
	       (gather (dcode-arg-symbol i) args))))
         (wrapper-bindings
	   (gathering ((bindings (collecting)))
	     (dolist (pos specialized-positions)
	       (gather (list (dcode-wrapper-symbol pos)
			     `(wrapper-of-2 ,(nth pos args)))
		       bindings))))
         (wrappers (mapcar #'car wrapper-bindings)))
    
    `(function
       (lambda (,@args ,@(and restp '(&rest rest-arg)))
	 (locally
	   (declare (optimize (speed 3)
			      (safety 0)
			      #+lucid (lucid::compilation-speed 0)))
	   (prog ((method-function nil)
		  ,@wrapper-bindings
		  (offset 0))
	      (declare (type #-kcl integer #+kcl fixnum offset))

	         (setq offset (cache-key-from-wrappers ,cache-size
						       ,line-size
						       ,@wrappers))
		 
		 (if (setq method-function
			   (cached-method .cache. offset ,@wrappers))
		     (return ,(if restp
				  `(apply method-function ,@args rest-arg)
				  `(funcall method-function ,@args)))
		     (progn
		       ;; ***
		       ;; *** Backing cache lookup code goes here.
		       ;; ***
		       (return 
			 (caching-dcode-miss .generic-function.
					     .cache.
					     ',cache-size
					     ',specialized-positions
					     ,(and restp 'rest-arg)
					     ,@args))))))))))


;in vector
(defun add-pv-binding (method-body plist required-parameters specializers)
  (flet ((parameter-class (param)
	   (iterate ((req (list-elements required-parameters))
		     (spec (list-elements specializers)))
	     (when (eq param req) (return spec)))))
    (let* ((isl (getf plist :isl))
	   (n-classes 0)
	   (cache-size (compute-primary-pv-cache-size isl))
	   (wrapper-var-pool '(w1 w2 w3 w4 w5 w6 w7 w8 w9))
	   (isl-cache-symbol (make-symbol "isl-cache")))
      (nconc plist (list :isl-cache-symbol isl-cache-symbol))
      
      (multiple-value-bind (wrapper-bindings
			    wrapper-vars
			    wrappers-and-parameters
			    eq-tests)
	  (gathering ((bindings (collecting))
		      (vars (collecting))
		      (w+p (collecting))
		      (eqs (collecting)))
	    (iterate ((slots (list-elements isl))
		      (param (list-elements required-parameters)))
	      (when slots
		(let ((class (find-class (parameter-class param)))
		      (var (or (pop wrapper-var-pool) (gensym))))
		  (gather var vars)
		  (gather var w+p)
		  (gather param w+p)
		  (gather `(,var (,(wrapper-fetcher  class) ,param)) bindings)
		  (gather `(eq ,var
			       (%svref .cache. ,(make-%+ '.offset. n-classes)))
			  eqs)
		  (incf n-classes)))))	
	`((let ((.isl. (locally 
			 (declare (special ,isl-cache-symbol))
			 ,isl-cache-symbol))
		(.pv. nil))
	    (setq .pv.
		  (let* ((.cache. (car .isl.))
			 ,@wrapper-bindings
			 (.offset.
			   (cache-key-from-wrappers ,cache-size
						    ,(1+ n-classes)
						    ,@wrapper-vars)))
		    (declare (type #-kcl integer #+kcl fixnum .offset.))
		    (if (and ,@eq-tests)
			(%svref .cache. ,(make-%+ '.offset. n-classes))
			(primary-pv-cache-miss .isl.
					       .offset.
					       ,@wrappers-and-parameters))))
	    .,method-body))))))