0.8pre.2

	Time to slip my PCL changes in under cover of CSR's patch landing:

	Apply patch from Gerd Moellmann to remove cacheing of GF
        caches.  This makes lots of WITHOUT-INTERRUPTSs in PCL code
        go away - a bonus for threading

          http://entomotomy.cliki.net/pcl-gf-cache-cacheing-not-needed

        Replaced remaining (two) WITHOUT-INTERRUPTSs with WITH-PCL-LOCK
        - a new macro that spinlocks around the approriate section.
	On unithread SBCL it actually does nothing at all, which I'm
	not sure about - we're assuming that WITHOUT-INTERRUPTS has been
	used as a substitute for WITHOUT-SCHEDULING.  This is likely
	but not certain

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index c3be109..fc92326 100644 (file)
--- 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)))
 \f
-;;; 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)))
+  
 \f
 ;;;; wrapper cache numbers
 
@@ -422,11 +365,9 @@
   (when (invalid-wrapper-p (layout-of instance))
     (check-wrapper-validity instance)))
 \f
-(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 +391,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 +426,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))
 
@@ -986,19 +919,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))
              (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)
 
@@ -1157,11 +1088,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))
@@ -1175,12 +1107,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))))
@@ -1188,7 +1119,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)))
@@ -1201,7 +1132,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)))))
 \f
 ;;; This is the heart of the cache filling mechanism. It implements

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 6846e0a..4d81f4b 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -628,8 +628,7 @@ And so, we are saved.
     (maphash (lambda (classes value)
               (setq cache (fill-cache cache
                                       (class-wrapper classes)
-                                      value
-                                      t)))
+                                      value)))
             table)
     cache))
 
@@ -1539,15 +1538,13 @@ And so, we are saved.
   (let* ((early-p (early-gf-p generic-function))
         (gf-name (if early-p
                      (!early-gf-name generic-function)
-                     (generic-function-name generic-function)))
-        (ocache (gf-dfun-cache generic-function)))
+                     (generic-function-name generic-function))))
     (set-dfun generic-function dfun cache info)
     (let ((dfun (if early-p
                    (or dfun (make-initial-dfun generic-function))
                    (compute-discriminating-function generic-function))))
       (set-funcallable-instance-function generic-function dfun)
       (set-fun-name generic-function gf-name)
-      (when (and ocache (not (eq ocache cache))) (free-cache ocache))
       dfun)))
 \f
 (defvar *dfun-count* nil)

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index 871b170..34537ac 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -360,3 +360,33 @@
 
 (defun structure-slotd-init-form (slotd)
   (dsd-default slotd))
+
+;;; WITH-PCL-LOCK is used around some forms that were previously
+;;; protected by WITHOUT-INTERRUPTS, but in a threaded SBCL we don't
+;;; have a useful WITHOUT-INTERRUPTS.  In an unthreaded SBCL I'm not
+;;; sure what the desired effect is anyway: should we be protecting
+;;; against the possibility of recursive calls into these functions
+;;; or are we using WITHOUT-INTERRUPTS as WITHOUT-SCHEDULING?
+;;;
+;;; Users: FORCE-CACHE-FLUSHES, MAKE-INSTANCES-OBSOLETE.  Note that
+;;; it's not all certain this is sufficent for threadsafety: do we
+;;; just have to protect against simultaneous calls to these mutators,
+;;; or actually to stop normal slot access etc at the same time as one
+;;; of them runs
+
+#+sb-thread
+(progn
+(defstruct spinlock (value 0))
+(defvar *pcl-lock* (make-spinlock))
+
+(defmacro with-pcl-lock (&body body)
+  `(progn
+    (sb-thread::get-spinlock *pcl-lock* 1 (sb-thread::current-thread-id))
+    (unwind-protect
+       (progn ,@body)
+      (setf (spinlock-value *pcl-lock*) 0))))
+);progn
+
+#-sb-thread
+(defmacro with-pcl-lock (&body body)
+  `(progn ,@body))

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 3ff601a..5fd798f 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -916,7 +916,7 @@
                                      ((eq valuep :constant-value)
                                       (value-for-caching generic-function
                                                          classes)))))
-                    (setq cache (fill-cache cache wrappers value t))))))))
+                    (setq cache (fill-cache cache wrappers value))))))))
       (if classes-list
          (mapc #'add-class-list classes-list)
          (dolist (method (generic-function-methods generic-function))

diff --git a/src/pcl/precom1.lisp b/src/pcl/precom1.lisp
index 635cad1..10daec6 100644 (file)
--- a/src/pcl/precom1.lisp
+++ b/src/pcl/precom1.lisp
@@ -23,21 +23,5 @@
 
 (in-package "SB-PCL")
 \f
-;;; Pre-allocate generic function caches. The hope is that this will put
-;;; them nicely together in memory, and that that may be a win. Of course
-;;; the first gc copy will probably blow that out, this really wants to be
-;;; wrapped in something that declares the area static.
-;;;
-;;; This preallocation only creates about 25% more caches than PCL itself
-;;; uses need. Some ports may want to preallocate some more of these.
-(flet ((allocate (n size)
-                (mapcar #'free-cache-vector
-                        (mapcar #'get-cache-vector
-                                (make-list n :initial-element size)))))
-  (allocate 128 4)
-  (allocate 64 8)
-  (allocate 64 9)
-  (allocate 32 16)
-  (allocate 16 17)
-  (allocate 16 32)
-  (allocate 1  64))
+;;; (We used to pre-allocate generic function caches here, but we let
+;;; the GC deal with that stuff these days)

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index a19070b..e7c1d86 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -58,7 +58,7 @@
         (error "unrecognized instance type"))))
 
 (defun swap-wrappers-and-slots (i1 i2)
-  (sb-sys:without-interrupts
+  (with-pcl-lock                       ;FIXME is this sufficient?
    (cond ((std-instance-p i1)
          (let ((w1 (std-instance-wrapper i1))
                (s1 (std-instance-slots i1)))

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 74dc13f..043e0da 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -1167,7 +1167,7 @@
              (wrapper-instance-slots-layout owrapper))
        (setf (wrapper-class-slots nwrapper)
              (wrapper-class-slots owrapper))
-       (sb-sys:without-interrupts
+       (with-pcl-lock
          (update-lisp-class-layout class nwrapper)
          (setf (slot-value class 'wrapper) nwrapper)
          (invalidate-wrapper owrapper :flush nwrapper))))))
@@ -1187,7 +1187,7 @@
            (wrapper-instance-slots-layout owrapper))
       (setf (wrapper-class-slots nwrapper)
            (wrapper-class-slots owrapper))
-      (sb-sys:without-interrupts
+      (with-pcl-lock
        (update-lisp-class-layout class nwrapper)
        (setf (slot-value class 'wrapper) nwrapper)
        (invalidate-wrapper owrapper :obsolete nwrapper)

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 26cc570..f4cab13 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -232,8 +232,7 @@
               (pv-cell (cons pv calls))
               (new-cache (fill-cache cache pv-wrappers pv-cell)))
          (unless (eq new-cache cache)
-           (setf (pv-table-cache pv-table) new-cache)
-           (free-cache cache))
+           (setf (pv-table-cache pv-table) new-cache))
          pv-cell))))
 
 (defun make-pv-type-declaration (var)

diff --git a/version.lisp-expr b/version.lisp-expr
index 6fd9413..55aaa35 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.pre8.1"
+"0.pre8.2"