X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=7536f2a76dadbd5b38b76fb13ff77f03fd97fcbf;hb=ae47ad0774edd8cb376772ae7e615428295f979e;hp=0106ba32a305c86be5e8af1af483b73aeef3ba52;hpb=a736ac10b709b2d40305f0a6e3764afd246a8ef5;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index 0106ba3..7536f2a 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -96,13 +96,13 @@
   `(cache-vector-ref ,cache-vector 0))
 
 (defun flush-cache-vector-internal (cache-vector)
-  (sb-sys:without-interrupts
+  (with-pcl-lock
     (fill (the simple-vector cache-vector) nil)
     (setf (cache-vector-lock-count cache-vector) 0))
   cache-vector)
 
 (defmacro modify-cache (cache-vector &body body)
-  `(sb-sys:without-interrupts
+  `(with-pcl-lock
      (multiple-value-prog1
        (progn ,@body)
        (let ((old-count (cache-vector-lock-count ,cache-vector)))
@@ -143,69 +143,12 @@
 (defmacro cache-lock-count (cache)
   `(cache-vector-lock-count (cache-vector ,cache)))
 
-;;; some facilities for allocation and freeing caches as they are needed
-
-;;; This is done on the assumption that a better port of PCL will
-;;; arrange to cons these all in the same static area. Given that, the
-;;; fact that PCL tries to reuse them should be a win.
-
-(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
-
 ;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on
 ;;; it. This returns a cache of exactly the size requested, it won't
 ;;; ever return a larger cache.
 (defun get-cache-vector (size)
-  (let ((entry (gethash size *free-cache-vectors*)))
-    (sb-sys:without-interrupts
-      (cond ((null entry)
-	     (setf (gethash size *free-cache-vectors*) (cons 0 nil))
-	     (get-cache-vector size))
-	    ((null (cdr entry))
-	     (incf (car entry))
-	     (flush-cache-vector-internal (allocate-cache-vector size)))
-	    (t
-	     (let ((cache (cdr entry)))
-	       (setf (cdr entry) (cache-vector-ref cache 0))
-	       (flush-cache-vector-internal cache)))))))
-
-(defun free-cache-vector (cache-vector)
-  (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
-    (sb-sys:without-interrupts
-      (if (null entry)
-	  (error
-	   "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
-	  (let ((thread (cdr entry)))
-	    (loop (unless thread (return))
-		  (when (eq thread cache-vector)
-		    (error "freeing a cache twice"))
-		  (setq thread (cache-vector-ref thread 0)))
-	    (flush-cache-vector-internal cache-vector) ; to help the GC
-	    (setf (cache-vector-ref cache-vector 0) (cdr entry))
-	    (setf (cdr entry) cache-vector)
-	    nil)))))
-
-;;; This is just for debugging and analysis. It shows the state of the
-;;; free cache resource.
-#+sb-show
-(defun show-free-cache-vectors ()
-  (let ((elements ()))
-    (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
-    (setq elements (sort elements #'< :key #'car))
-    (dolist (e elements)
-      (let* ((size (car e))
-	     (entry (cadr e))
-	     (allocated (car entry))
-	     (head (cdr entry))
-	     (free 0))
-	(loop (when (null head) (return t))
-	      (setq head (cache-vector-ref head 0))
-	      (incf free))
-	(format t
-		"~&There are  ~4D caches of size  ~4D. (~D free  ~3D%)"
-		allocated
-		size
-		free
-		(floor (* 100 (/ free (float allocated)))))))))
+  (flush-cache-vector-internal (make-array size)))
+  
 
 ;;;; wrapper cache numbers
 
@@ -261,6 +204,7 @@
 (defmacro wrapper-no-of-instance-slots (wrapper)
   `(layout-length ,wrapper))
 
+;;; FIXME: Why are these macros?
 (defmacro wrapper-instance-slots-layout (wrapper)
   `(%wrapper-instance-slots-layout ,wrapper))
 (defmacro wrapper-class-slots (wrapper)
@@ -298,35 +242,36 @@
 ;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
 (defun make-wrapper (length class)
   (cond
-   ((typep class 'std-class)
-    (make-wrapper-internal
-     :length length
-     :classoid
-     (let ((owrap (class-wrapper class)))
-       (cond (owrap
-	      (layout-classoid owrap))
-	     ((*subtypep (class-of class)
-			 *the-class-standard-class*)
-	      (cond ((and *pcl-class-boot*
-			  (eq (slot-value class 'name) *pcl-class-boot*))
-		     (let ((found (find-classoid
-				   (slot-value class 'name))))
-		       (unless (classoid-pcl-class found)
-			 (setf (classoid-pcl-class found) class))
-		       (aver (eq (classoid-pcl-class found) class))
-		       found))
-		    (t
-		     (make-standard-classoid :pcl-class class))))
-	     (t
-	      (make-random-pcl-classoid :pcl-class class))))))
-   (t
-    (let* ((found (find-classoid (slot-value class 'name)))
-	   (layout (classoid-layout found)))
-      (unless (classoid-pcl-class found)
-	(setf (classoid-pcl-class found) class))
-      (aver (eq (classoid-pcl-class found) class))
-      (aver layout)
-      layout))))
+    ((or (typep class 'std-class)
+	 (typep class 'forward-referenced-class))
+     (make-wrapper-internal
+      :length length
+      :classoid
+      (let ((owrap (class-wrapper class)))
+	(cond (owrap
+	       (layout-classoid owrap))
+	      ((or (*subtypep (class-of class) *the-class-standard-class*)
+		   (typep class 'forward-referenced-class))
+	       (cond ((and *pcl-class-boot*
+			   (eq (slot-value class 'name) *pcl-class-boot*))
+		      (let ((found (find-classoid
+				    (slot-value class 'name))))
+			(unless (classoid-pcl-class found)
+			  (setf (classoid-pcl-class found) class))
+			(aver (eq (classoid-pcl-class found) class))
+			found))
+		     (t
+		      (make-standard-classoid :pcl-class class))))
+	      (t
+	       (make-random-pcl-classoid :pcl-class class))))))
+    (t
+     (let* ((found (find-classoid (slot-value class 'name)))
+	    (layout (classoid-layout found)))
+       (unless (classoid-pcl-class found)
+	 (setf (classoid-pcl-class found) class))
+       (aver (eq (classoid-pcl-class found) class))
+       (aver layout)
+       layout))))
 
 (defconstant +first-wrapper-cache-number-index+ 0)
 
@@ -357,7 +302,7 @@
 (declaim (inline wrapper-class*))
 (defun wrapper-class* (wrapper)
   (or (wrapper-class wrapper)
-      (find-structure-class
+      (ensure-non-standard-class
        (classoid-name (layout-classoid wrapper)))))
 
 ;;; The wrapper cache machinery provides general mechanism for
@@ -409,24 +354,37 @@
 (defun check-wrapper-validity (instance)
   (let* ((owrapper (wrapper-of instance))
 	 (state (layout-invalid owrapper)))
-    (if (null state)
-	owrapper
-	(ecase (car state)
-	  (:flush
-	   (flush-cache-trap owrapper (cadr state) instance))
-	  (:obsolete
-	   (obsolete-instance-trap owrapper (cadr state) instance))))))
+    (aver (not (eq state :uninitialized)))
+    (etypecase state
+      (null owrapper)
+      ;; FIXME: I can't help thinking that, while this does cure the
+      ;; symptoms observed from some class redefinitions, this isn't
+      ;; the place to be doing this flushing.  Nevertheless...  --
+      ;; CSR, 2003-05-31
+      ;;
+      ;; CMUCL comment:
+      ;;    We assume in this case, that the :INVALID is from a
+      ;;    previous call to REGISTER-LAYOUT for a superclass of
+      ;;    INSTANCE's class.  See also the comment above
+      ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
+      ((member t)
+       (force-cache-flushes (class-of instance))
+       (check-wrapper-validity instance))
+      (cons
+       (ecase (car state)
+	 (:flush
+	  (flush-cache-trap owrapper (cadr state) instance))
+	 (:obsolete
+	  (obsolete-instance-trap owrapper (cadr state) instance)))))))
 
 (declaim (inline check-obsolete-instance))
 (defun check-obsolete-instance (instance)
   (when (invalid-wrapper-p (layout-of instance))
     (check-wrapper-validity instance)))
 
-(defvar *free-caches* nil)
 
 (defun get-cache (nkeys valuep limit-fn nlines)
-  (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
-                   (make-cache))))
+  (let ((cache (make-cache)))
     (declare (type cache cache))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
 	(compute-cache-parameters nkeys valuep nlines)
@@ -450,8 +408,7 @@
 			     &optional (new-field +first-wrapper-cache-number-index+))
   (let ((nkeys (cache-nkeys old-cache))
 	(valuep (cache-valuep old-cache))
-	(cache (or (sb-sys:without-interrupts (pop *free-caches*))
-                   (make-cache))))
+	(cache (make-cache)))
     (declare (type cache cache))
     (multiple-value-bind (cache-mask actual-size line-size nlines)
 	(if (= new-nlines (cache-nlines old-cache))
@@ -486,13 +443,6 @@
     (setf (cache-vector new-cache) new-vector)
     new-cache))
 
-(defun free-cache (cache)
-  (free-cache-vector (cache-vector cache))
-  (setf (cache-vector cache) #())
-  (setf (cache-owner cache) nil)
-  (push cache *free-caches*)
-  nil)
-
 (defun compute-line-size (x)
   (power-of-two-ceiling x))
 
@@ -610,6 +560,7 @@
 	(std       (find-class 'std-class))
 	(standard  (find-class 'standard-class))
 	(fsc       (find-class 'funcallable-standard-class))
+	(condition (find-class 'condition-class))
 	(structure (find-class 'structure-class))
 	(built-in  (find-class 'built-in-class)))
     (flet ((specializer->metatype (x)
@@ -617,22 +568,19 @@
 		     (if (eq *boot-state* 'complete)
 			 (class-of (specializer-class x))
 			 (class-of x))))
-	       (cond ((eq x *the-class-t*) t)
-		     ((*subtypep meta-specializer std)
-		      'standard-instance)
-		     ((*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)
-		     ((*subtypep meta-specializer slot)
-		      'slot-instance)
-		     (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
-			       new-specializer
-			       meta-specializer))))))
+	       (cond
+		 ((eq x *the-class-t*) t)
+		 ((*subtypep meta-specializer std) 'standard-instance)
+		 ((*subtypep meta-specializer standard) 'standard-instance)
+		 ((*subtypep meta-specializer fsc) 'standard-instance)
+		 ((*subtypep meta-specializer condition) 'condition-instance)
+		 ((*subtypep meta-specializer structure) 'structure-instance)
+		 ((*subtypep meta-specializer built-in) 'built-in-instance)
+		 ((*subtypep meta-specializer slot) 'slot-instance)
+		 (t (error "~@<PCL cannot handle the specializer ~S ~
+                            (meta-specializer ~S).~@:>"
+			   new-specializer
+			   meta-specializer))))))
       ;; We implement the following table. The notation is
       ;; that X and Y are distinct meta specializer names.
       ;;
@@ -703,13 +651,13 @@
 
 (defun dfun-arg-symbol (arg-number)
   (or (nth arg-number (the list *dfun-arg-symbols*))
-      (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
+      (format-symbol *pcl-package* ".ARG~A." arg-number)))
 
 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
 
 (defun slot-vector-symbol (arg-number)
   (or (nth arg-number (the list *slot-vector-symbols*))
-      (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
+      (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
 
 ;; FIXME: There ought to be a good way to factor out the idiom:
 ;;
@@ -988,19 +936,17 @@
 ;;; nice property of throwing out any entries that are invalid.
 (defvar *cache-expand-threshold* 1.25)
 
-(defun fill-cache (cache wrappers value &optional free-cache-p)
-
+(defun fill-cache (cache wrappers value)
   ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
-  (unless wrappers
-    (error "fill-cache: WRAPPERS arg is NIL!"))
+  (assert wrappers)
 
   (or (fill-cache-p nil cache wrappers value)
-      (and (< (ceiling (* (cache-count cache) 1.25))
+      (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*))
 	      (if (= (cache-nkeys cache) 1)
 		  (1- (cache-nlines cache))
 		  (cache-nlines cache)))
-	   (adjust-cache cache wrappers value free-cache-p))
-      (expand-cache cache wrappers value free-cache-p)))
+	   (adjust-cache cache wrappers value))
+      (expand-cache cache wrappers value)))
 
 (defvar *check-cache-p* nil)
 
@@ -1159,11 +1105,12 @@
 ;;; If this returns NIL, it means that it wasn't possible to find a
 ;;; wrapper field for which all of the entries could be put in the
 ;;; cache (within the limit).
-(defun adjust-cache (cache wrappers value free-old-cache-p)
+(defun adjust-cache (cache wrappers value)
   (with-local-cache-functions (cache)
     (let ((ncache (get-cache-from-cache cache (nlines) (field))))
-      (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
-	  ((null nfield) (free-cache ncache) nil)
+      (do ((nfield (cache-field ncache)
+		   (next-wrapper-cache-number-index nfield)))
+	  ((null nfield) nil)
 	(setf (cache-field ncache) nfield)
 	(labels ((try-one-fill-from-line (line)
 		   (fill-cache-from-cache-p nil ncache cache line))
@@ -1177,12 +1124,11 @@
 		     (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
 		       (return nil)))
 		   (try-one-fill wrappers value))
-	      (progn (when free-old-cache-p (free-cache cache))
-		     (return (maybe-check-cache ncache)))
+	      (return (maybe-check-cache ncache))
 	      (flush-cache-vector-internal (cache-vector ncache))))))))
 
 ;;; returns: (values <cache>)
-(defun expand-cache (cache wrappers value free-old-cache-p)
+(defun expand-cache (cache wrappers value)
   ;;(declare (values cache))
   (with-local-cache-functions (cache)
     (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
@@ -1190,7 +1136,7 @@
 		 (unless (fill-cache-from-cache-p nil ncache cache line)
 		   (do-one-fill (line-wrappers line) (line-value line))))
 	       (do-one-fill (wrappers value)
-		 (setq ncache (or (adjust-cache ncache wrappers value t)
+		 (setq ncache (or (adjust-cache ncache wrappers value)
 				  (fill-cache-p t ncache wrappers value))))
 	       (try-one-fill (wrappers value)
 		 (fill-cache-p nil ncache wrappers value)))
@@ -1203,7 +1149,6 @@
 	    (do-one-fill (car wrappers+value) (cdr wrappers+value))))
 	(unless (try-one-fill wrappers value)
 	  (do-one-fill wrappers value))
-	(when free-old-cache-p (free-cache cache))
 	(maybe-check-cache ncache)))))
 
 ;;; This is the heart of the cache filling mechanism. It implements