From dc86450e18fb7b90bf6be7d8df8b8ebcb0d090f9 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Tue, 25 Mar 2003 00:13:10 +0000 Subject: [PATCH] 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 --- src/pcl/cache.lisp | 104 ++++++++---------------------------------------- src/pcl/dfun.lisp | 7 +--- src/pcl/low.lisp | 30 ++++++++++++++ src/pcl/methods.lisp | 2 +- src/pcl/precom1.lisp | 20 +--------- src/pcl/slots.lisp | 2 +- src/pcl/std-class.lisp | 4 +- src/pcl/vector.lisp | 3 +- version.lisp-expr | 2 +- 9 files changed, 57 insertions(+), 117 deletions(-) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index c3be109..fc92326 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 @@ -422,11 +365,9 @@ (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 +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 ) -(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))))) ;;; 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 --- 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))) (defvar *dfun-count* nil) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 871b170..34537ac 100644 --- 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 --- 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 --- a/src/pcl/precom1.lisp +++ b/src/pcl/precom1.lisp @@ -23,21 +23,5 @@ (in-package "SB-PCL") -;;; 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4