recursive cache expanding bug

[kanderso@DINO.BBN.COM]

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

#||
Two bug fixes.  I'm not sure, but the second one might be related to
the problem Mike Thome was having.

1.  Fixed a bug in ENSURE-GENERIC-FUNCTION-CACHE that throws away a
cache that has just grown because it was too big, so gf's grow and
then shrink as they are invalidated and used.

||#

(defun ensure-generic-function-cache (generic-function size)
  (let ((existing (generic-function-cache generic-function)))
    (cond ((null existing)
	   (setq existing (get-generic-function-cache size))
	   (setf (generic-function-cache generic-function) existing))
	  ((< (GENERIC-FUNCTION-CACHE-SIZE EXISTING) SIZE)
	   (free-generic-function-cache existing)
	   (setq existing (get-generic-function-cache size))
	   (setf (generic-function-cache generic-function) existing)))
    existing))

#||

2.  Suppose something calls CLASS-DIRECT-SUBCLASSES,
EXPAND-DCODE-CACHE is called to expand the cache of
CLASS-DIRECT-SUBCLASSES and either GENERIC-FUNCTION-CACHE or
SLOT-VALUE-USING-CLASS are invalidated.  Then the innocent looking
line

 (SETF (GENERIC-FUNCTION-CACHE NEW-CACHE) GENERIC-FUNCTION)

at the bottom of EXPAND-DCODE-CACHE will cause EXPAND-DCODE-CACHE to
be called again on the same cache (because CLASS-DIRECT-SUBCLASSES
gets called in while computing the combined methods).  This trashes
the *free-generic-function-caches*.

The patch below avoids this extra expansion by making the SETF more
"atomic".

(Is this really another cache locking issue?)

||#
(defun expand-dcode-cache (generic-function
			   old-cache
			   old-size
			   line-size
			   nkeys
			   next-scan-limit
			   dcode-constructor)
  (let* ((new-size (* old-size 2))
	 (new-number-of-lines (floor new-size line-size))
	 (new-mask (make-wrapper-cache-mask new-number-of-lines))
	 (new-cache (get-generic-function-cache new-size))
	 (new-dcode nil)
	 (wrappers ())
	 (value nil))
    (flet ((%SET-GENERIC-FUNCTION-CACHE (NV OBJECT)
	     ;; Set the generic function cache avoiding another expansion.
	     (LET ((SLOT-NAME 'CACHE))
	       (BIND-WRAPPER-AND-STATIC-SLOTS--FSC OBJECT
		 (SETF-SLOT-VALUE-USING-CLASS-1))))
	   (collect-wrappers (loc)
	     (block collect-wrappers
	       (when (%svref old-cache loc)
		 (setq wrappers ())
		 (dotimes (i nkeys)
		   (let ((wrapper (%svref old-cache (+ i loc))))
		     (if (zerop (wrapper-cache-no wrapper))
			 ;; This wrapper is obsolete, we don't have an instance
			 ;; so there is no related trap.  Just drop this line
			 ;; on the floor.
			 (return-from collect-wrappers nil)
			 (push wrapper wrappers))))
		 (setq wrappers (nreverse wrappers)
		       value (and (< nkeys line-size)
				  (%svref old-cache (+ loc nkeys))))
		 t))))

      (flush-generic-function-caches-internal new-cache)

      (do ((old-location line-size (+ old-location line-size)))
	  ((= old-location old-size))
	(when (collect-wrappers old-location)
	  (apply #'dcode-cache-miss
		 generic-function
		 #'(lambda (&rest ignore)
		     (declare (ignore ignore))
		     value)
		 new-cache
		 new-size
		 new-mask
		 line-size
		 nkeys
		 next-scan-limit
		 nil				;Means don't allow another
						;expand while filling the
						;new cache.  This can only
						;happen in one pathological
						;case, but prevent it anyways.
		 dcode-constructor
		 wrappers)))
    
      (setq new-dcode (funcall dcode-constructor generic-function new-cache))
      (%SET-GENERIC-FUNCTION-CACHE NEW-CACHE GENERIC-FUNCTION)
      (install-discriminating-function generic-function new-dcode)
      (free-generic-function-cache old-cache)
      new-cache)))