Re: PCL benchmark

[harrisr@turing.cs.rpi.edu (Richard Harris)]

There was an error in my previous message:
the line 
	    (when (eq n 'iwmc-class-p) return t)
in (si:define-compiler-macro iwmc-class-p (x)
should be
	    (when (eq n 'iwmc-class) (return t)

The remaining thing that must be done so that
method lookup and slot access in KCL 
will not cause unnecessary function calling is 
to declare some of variables that always have fixnum values.
Otherwise, KCL always allocates storage (2 words) each time 
these variables are bound or set.

Rick Harris

;(defvar *pcl-system-date* "8/28/88 (beta rev 1) AAAI PCL ")
;in slots
(defmacro get-slot-value-1 (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
	       (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))))))