diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 2327bfc6a59ddc7d8c06465a6eb06083f8c1df4b..4fccbc03d49b51d918788285a0d63628adcc6013 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.22 2002/11/21 22:09:13 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.23 2002/12/18 00:57:04 pmai Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. ;;; @@ -163,70 +163,13 @@ `(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 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*))) - (with-pcl-lock - (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*))) - (with-pcl-lock - (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) ;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. -;;; -(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 ~4D are caches of size ~4D. (~D free ~3D%)" - allocated - size - free - (floor (* 100 (/ free (float allocated))))))))) + (flush-cache-vector-internal (make-array size))) ;;; @@ -481,10 +424,8 @@ -(defvar *free-caches* nil) - (defun get-cache (nkeys valuep limit-fn nlines) - (let ((cache (or (with-pcl-lock (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) @@ -508,7 +449,7 @@ &optional (new-field (first-wrapper-cache-number-index))) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) - (cache (or (with-pcl-lock (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)) @@ -544,13 +485,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)) @@ -1028,17 +962,17 @@ ;;; (defvar *cache-expand-threshold* 1.25) -(defun fill-cache (cache wrappers value &optional free-cache-p) +(defun fill-cache (cache wrappers value) ;;(declare (values cache)) - (unless wrappers ; fill-cache won't return if wrappers is nil, might as well check. - (error "fill-cache: wrappers arg is NIL!")) + ;; fill-cache won't return if wrappers is nil, might as well check. + (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) @@ -1203,11 +1137,13 @@ ;;; 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) + (when (< nfield (1- kernel:layout-hash-length)) + (1+ 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)) @@ -1222,15 +1158,14 @@ (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)) + (progn (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)))) @@ -1238,7 +1173,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))) @@ -1252,7 +1187,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))))) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index 9bee7a6574720622f59cd5c9e077085ad6d56080..f076ee89ee2fe18a759b60c30c5472326060863b 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.16 2002/11/28 16:23:32 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.17 2002/12/18 00:57:04 pmai Exp $") ;;; (in-package :pcl) @@ -685,8 +685,7 @@ And so, we are saved. (maphash (lambda (classes value) (setq cache (fill-cache cache (class-wrapper classes) - value - t))) + value))) table) cache)) @@ -1537,15 +1536,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-function-name generic-function gf-name) - (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 1803b22a66edcec65194dcfce68b7800c64eed25..19680a93b5fb49f6da5d71b545c186e21e6d8318 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.18 2002/11/28 16:23:34 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.19 2002/12/18 00:57:05 pmai Exp $") ;;; (in-package :pcl) @@ -987,7 +987,7 @@ (sdfun-for-caching generic-function classes)) ((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/pcl/precom1.lisp b/pcl/precom1.lisp index 645178e1ae2d30fc653a804ac74a0bf7ace89b17..5977c0d80aa565e786c3e9cd17a3b076dee8f236 100644 --- a/pcl/precom1.lisp +++ b/pcl/precom1.lisp @@ -25,27 +25,3 @@ ;;; ************************************************************************* ;;; -(in-package :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. -;;; -(eval-when (:load-toplevel) - (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))) - diff --git a/pcl/vector.lisp b/pcl/vector.lisp index f9e62319ba931bf8b068125af527208419c69a10..9f26256c748ee725f669020993c74545b8beb028 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.24 2002/12/18 00:16:33 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.25 2002/12/18 00:57:05 pmai Exp $") ;;; ;;; Permutation vectors. ;;; @@ -241,8 +241,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)