X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=627b660c29ee6c64409d5d6659f6a04610c2f119;hb=416152f084604094445a758ff399871132dff2bd;hp=4bc0854500c2431d5af13b74d6482aac33573ae6;hpb=2716573f357f204c5f546d1d34d285dd24ff43a1;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 4bc0854..627b660 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -25,18 +25,6 @@ (in-package "SB-PCL") -;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL -;;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends -;;; up using a thundering herd of explicit prefixes to get to -;;; SB-KERNEL symbols. Using the SB-INT and SB-EXT packages as well -;;; would help reduce prefixing and make it more natural to reuse -;;; things (ONCE-ONLY, *KEYWORD-PACKAGE*..) used in the main body of -;;; the system. However, that would cause a conflict between the -;;; SB-ITERATE:ITERATE macro and the SB-INT:ITERATE macro. (This could -;;; be resolved by renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or -;;; with more gruntwork by punting the SB-ITERATE package and -;;; replacing calls to SB-ITERATE:ITERATE with calls to CL:LOOP. - ;;; The caching algorithm implemented: ;;; ;;; << put a paper here >> @@ -108,13 +96,13 @@ `(cache-vector-ref ,cache-vector 0)) (defun flush-cache-vector-internal (cache-vector) - (without-interrupts + (sb-sys:without-interrupts (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) (defmacro modify-cache (cache-vector &body body) - `(without-interrupts + `(sb-sys:without-interrupts (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) @@ -168,7 +156,7 @@ ;;; ever return a larger cache. (defun get-cache-vector (size) (let ((entry (gethash size *free-cache-vectors*))) - (without-interrupts + (sb-sys:without-interrupts (cond ((null entry) (setf (gethash size *free-cache-vectors*) (cons 0 nil)) (get-cache-vector size)) @@ -182,7 +170,7 @@ (defun free-cache-vector (cache-vector) (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) - (without-interrupts + (sb-sys:without-interrupts (if (null entry) (error "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR") @@ -283,7 +271,8 @@ ;; default here. -- WHN 19991204 (invalid nil)) (:conc-name %wrapper-) - (:constructor make-wrapper-internal)) + (:constructor make-wrapper-internal) + (:copier nil)) (instance-slots-layout nil :type list) (class-slots nil :type list)) #-sb-fluid (declaim (sb-ext:freeze-type wrapper)) @@ -327,7 +316,7 @@ invalid)))) (defun (setf wrapper-state) (new-value wrapper) (setf (sb-kernel:layout-invalid wrapper) - (if (eq new-value 't) + (if (eq new-value t) nil new-value))) @@ -346,9 +335,9 @@ (found (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) + (aver (eq (sb-kernel:class-pcl-class found) class)) (let ((layout (sb-kernel:class-layout found))) - (assert layout) + (aver layout) layout)) (t (make-wrapper-internal @@ -381,7 +370,7 @@ (let ((found (cl:find-class (slot-value class 'name)))) (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) + (aver (eq (sb-kernel:class-pcl-class found) class)) found)) (t (sb-kernel:make-standard-class :pcl-class class)))) @@ -392,8 +381,8 @@ (layout (sb-kernel:class-layout found))) (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) - (assert layout) + (aver (eq (sb-kernel:class-pcl-class found) class)) + (aver layout) layout)))) ;;; FIXME: The immediately following macros could become inline functions. @@ -435,7 +424,7 @@ ;;; FIXME: could become inline function (defmacro invalid-wrapper-p (wrapper) - `(neq (wrapper-state ,wrapper) 't)) + `(neq (wrapper-state ,wrapper) t)) (defvar *previous-nwrappers* (make-hash-table)) @@ -469,7 +458,7 @@ (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) (state (wrapper-state owrapper))) - (if (eq state 't) + (if (eq state t) owrapper (let ((nwrapper (ecase (car state) @@ -503,7 +492,8 @@ (defvar *free-caches* nil) (defun get-cache (nkeys valuep limit-fn nlines) - (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*)) + (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (compute-cache-parameters nkeys valuep nlines) @@ -527,7 +517,8 @@ &optional (new-field (first-wrapper-cache-number-index))) (let ((nkeys (cache-nkeys old-cache)) (valuep (cache-valuep old-cache)) - (cache (or (without-interrupts (pop *free-caches*)) (make-cache)))) + (cache (or (sb-sys:without-interrupts (pop *free-caches*)) + (make-cache)))) (declare (type cache cache)) (multiple-value-bind (cache-mask actual-size line-size nlines) (if (= new-nlines (cache-nlines old-cache)) @@ -588,7 +579,7 @@ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) cache-size line-size - (the fixnum (floor cache-size line-size)))) + (the (values fixnum t) (floor cache-size line-size)))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) (cache-size (if (typep nlines-or-cache-vector 'fixnum) (the fixnum @@ -601,7 +592,7 @@ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) (the fixnum (1+ cache-size)) line-size - (the fixnum (floor cache-size line-size)))))) + (the (values fixnum t) (floor cache-size line-size)))))) ;;; the various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are @@ -613,8 +604,6 @@ ;;; ENSURING that the result is a fixnum ;;; MASK the result against the mask argument. -;;; COMPUTE-PRIMARY-CACHE-LOCATION -;;; ;;; The basic functional version. This is used by the cache miss code to ;;; compute the primary location of an entry. (defun compute-primary-cache-location (field mask wrappers) @@ -643,8 +632,6 @@ (incf i)) (the fixnum (1+ (logand mask location)))))) -;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION -;;; ;;; This version is called on a cache line. It fetches the wrappers ;;; from the cache line and determines the primary location. Various ;;; parts of the cache filling code call this to determine whether it @@ -742,8 +729,8 @@ (wrapper nil) ,@(when wrappers `((class *the-class-t*) - (type 't)))) - (unless (eq mt 't) + (type t)))) + (unless (eq mt t) (setq wrapper (wrapper-of arg)) (when (invalid-wrapper-p wrapper) (setq ,invalid-wrapper-p t)