X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=129ebbf6ea61ae2ee4ae3d5b184b6605ae8e3a25;hb=17532463fa19f2fc2aba53b65c32e200a27ccd6a;hp=bdb7811ecb36878e9a2234d6be8f96a3a262c08c;hpb=bb8121bf453353ce2cadc85d9be7be05ca6248ff;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index bdb7811..129ebbf 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -96,18 +96,26 @@
 (defmacro cache-vector-size (cache-vector)
   `(array-dimension (the simple-vector ,cache-vector) 0))
 
-(defun allocate-cache-vector (size)
-  (make-array size :adjustable nil))
-
 (defmacro cache-vector-lock-count (cache-vector)
   `(cache-vector-ref ,cache-vector 0))
 
 (defun flush-cache-vector-internal (cache-vector)
+  ;; FIXME: To my eye this PCL-LOCK implies we should be holding the
+  ;; lock whenever we play with any cache vector, which doesn't seem
+  ;; to be true. On the other hand that would be too expensive as
+  ;; well, since it would mean serialization across all GFs.
   (with-pcl-lock
     (fill (the simple-vector cache-vector) nil)
     (setf (cache-vector-lock-count cache-vector) 0))
   cache-vector)
 
+;;; Return an empty cache vector
+(defun get-cache-vector (size)
+  (declare (type (and unsigned-byte fixnum) size))
+  (let ((cv (make-array size :initial-element nil)))
+    (setf (cache-vector-lock-count cv) 0)
+    cv))
+
 (defmacro modify-cache (cache-vector &body body)
   `(with-pcl-lock
      (multiple-value-prog1
@@ -116,17 +124,24 @@
          (declare (fixnum old-count))
          (setf (cache-vector-lock-count ,cache-vector)
                (if (= old-count most-positive-fixnum)
-                   1 (the fixnum (1+ old-count))))))))
+                   1
+                   (1+ old-count)))))))
 
 (deftype field-type ()
   '(mod #.layout-clos-hash-length))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-(defun power-of-two-ceiling (x)
-  (declare (fixnum x))
-  ;;(expt 2 (ceiling (log x 2)))
-  (the fixnum (ash 1 (integer-length (1- x)))))
-) ; EVAL-WHEN
+  (declaim (ftype (function (fixnum) (values (and unsigned-byte fixnum) &optional))
+                  power-of-two-ceiling))
+  (defun power-of-two-ceiling (x)
+    ;; (expt 2 (ceiling (log x 2)))
+    (ash 1 (integer-length (1- x)))))
+
+;;; FIXME: We should probably keep just one of these -- or at least use just
+;;; one.
+(declaim (inline compute-line-size))
+(defun compute-line-size (x)
+  (power-of-two-ceiling x))
 
 (defconstant +nkeys-limit+ 256)
 
@@ -146,16 +161,6 @@
   (overflow nil :type list))
 
 #-sb-fluid (declaim (sb-ext:freeze-type cache))
-
-(defmacro cache-lock-count (cache)
-  `(cache-vector-lock-count (cache-vector ,cache)))
-
-;;; 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)
-  (flush-cache-vector-internal (make-array size)))
-
 
 ;;;; wrapper cache numbers
 
@@ -211,13 +216,6 @@
 (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)
-  `(%wrapper-class-slots ,wrapper))
-(defmacro wrapper-cache-number-vector (x) x)
-
 ;;; This is called in BRAID when we are making wrappers for classes
 ;;; whose slots are not initialized yet, and which may be built-in
 ;;; classes. We pass in the class name in addition to the class.
@@ -295,15 +293,11 @@
 ;;; comment explaining why the separation is valuable, or to collapse
 ;;; it into a single layer.
 ;;;
-;;; FIXME (?): These are logically inline functions, but they need to
-;;; be SETFable, and for now it seems not worth the trouble to DEFUN
-;;; both inline FOO and inline (SETF FOO) for each one instead of a
-;;; single macro. Perhaps the best thing would be to make them
-;;; immutable (since it seems sort of surprising and gross to be able
-;;; to modify hash values) so that they can become inline functions
-;;; with no muss or fuss. I (WHN) didn't do this only because I didn't
-;;; know whether any code anywhere depends on the values being
-;;; modified.
+;;; Second FIXME deleted from here. Setting the "hash" values is OK:
+;;; that's part of the magic we need to do to obsolete things. The
+;;; hash values are used as indexes to the cache vectors. Nikodemus
+;;; thinks both "layers" should go away, and we should just use the
+;;; LAYOUT-CLOS-HASH directly.
 (defmacro cache-number-vector-ref (cnv n)
   `(wrapper-cache-number-vector-ref ,cnv ,n))
 (defmacro wrapper-cache-number-vector-ref (wrapper n)
@@ -332,6 +326,7 @@
 (defun invalid-wrapper-p (wrapper)
   (not (null (layout-invalid wrapper))))
 
+;;; FIXME: This needs a lock
 (defvar *previous-nwrappers* (make-hash-table))
 
 (defun invalidate-wrapper (owrapper state nwrapper)
@@ -351,15 +346,15 @@
       (setf (cadr previous) nwrapper)
       (push previous new-previous))
 
-    (let ((ocnv (wrapper-cache-number-vector owrapper)))
-      (dotimes (i layout-clos-hash-length)
-        (setf (cache-number-vector-ref ocnv i) 0)))
-
+    (dotimes (i layout-clos-hash-length)
+      (setf (cache-number-vector-ref owrapper i) 0))
+    ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER)
+    ;; instead
     (push (setf (layout-invalid owrapper) (list state nwrapper))
           new-previous)
 
-    (setf (gethash owrapper *previous-nwrappers*) ()
-          (gethash nwrapper *previous-nwrappers*) new-previous)))
+    (remhash owrapper *previous-nwrappers*)
+    (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
 
 (defun check-wrapper-validity (instance)
   (let* ((owrapper (wrapper-of instance))
@@ -453,39 +448,34 @@
     (setf (cache-vector new-cache) new-vector)
     new-cache))
 
-(defun compute-line-size (x)
-  (power-of-two-ceiling x))
-
 (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
   ;;(declare (values cache-mask actual-size line-size nlines))
   (declare (fixnum nkeys))
   (if (= nkeys 1)
       (let* ((line-size (if valuep 2 1))
-             (cache-size (if (typep nlines-or-cache-vector 'fixnum)
-                             (the fixnum
-                                  (* line-size
-                                     (the fixnum
-                                          (power-of-two-ceiling
-                                            nlines-or-cache-vector))))
-                             (cache-vector-size nlines-or-cache-vector))))
-        (declare (fixnum line-size cache-size))
-        (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+             (cache-size (etypecase nlines-or-cache-vector
+                           (fixnum
+                            (* line-size
+                               (power-of-two-ceiling nlines-or-cache-vector)))
+                           (vector
+                            (cache-vector-size nlines-or-cache-vector)))))
+        (declare (type (and unsigned-byte fixnum) line-size cache-size))
+        (values (logxor (1- cache-size) (1- line-size))
                 cache-size
                 line-size
-                (the (values fixnum t) (floor cache-size line-size))))
+                (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
-                                  (* line-size
-                                     (the fixnum
-                                          (power-of-two-ceiling
-                                            nlines-or-cache-vector))))
-                             (1- (cache-vector-size nlines-or-cache-vector)))))
+             (cache-size (etypecase nlines-or-cache-vector
+                           (fixnum
+                            (* line-size
+                                (power-of-two-ceiling nlines-or-cache-vector)))
+                           (vector
+                             (1- (cache-vector-size nlines-or-cache-vector))))))
         (declare (fixnum line-size cache-size))
-        (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
-                (the fixnum (1+ cache-size))
+        (values (logxor (1- cache-size) (1- line-size))
+                (1+ cache-size)
                 line-size
-                (the (values fixnum t) (floor cache-size line-size))))))
+                (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
@@ -500,12 +490,12 @@
 ;;; 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)
-
   (declare (type field-type field) (fixnum mask))
   (if (not (listp wrappers))
       (logand mask
               (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
-      (let ((location 0) (i 0))
+      (let ((location 0)
+            (i 0))
         (declare (fixnum location i))
         (dolist (wrapper wrappers)
           ;; First add the cache number of this wrapper to location.
@@ -514,8 +504,7 @@
             (declare (fixnum wrapper-cache-number))
             (if (zerop wrapper-cache-number)
                 (return-from compute-primary-cache-location 0)
-                (setq location
-                      (the fixnum (+ location wrapper-cache-number)))))
+                (incf location wrapper-cache-number)))
           ;; Then, if we are working with lots of wrappers, deal with
           ;; the wrapper-cache-number-mask stuff.
           (when (and (not (zerop i))
@@ -523,7 +512,7 @@
             (setq location
                   (logand location wrapper-cache-number-mask)))
           (incf i))
-        (the fixnum (1+ (logand mask location))))))
+        (1+ (logand mask location)))))
 
 ;;; This version is called on a cache line. It fetches the wrappers
 ;;; from the cache line and determines the primary location. Various
@@ -549,13 +538,13 @@
       (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
              (wcn (wrapper-cache-number-vector-ref wrapper field)))
         (declare (fixnum wcn))
-        (setq result (+ result wcn)))
+        (incf result wcn))
       (when (and (not (zerop i))
                  (zerop (mod i wrapper-cache-number-adds-ok)))
         (setq result (logand result wrapper-cache-number-mask))))
     (if (= nkeys 1)
         (logand mask result)
-        (the fixnum (1+ (logand mask result))))))
+        (1+ (logand mask result)))))
 
 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
 ;;;  metatype
@@ -661,75 +650,84 @@
 ;;;; symbols because we don't capture any user code in the scope in which
 ;;;; these symbols are bound.
 
+(declaim (list *dfun-arg-symbols*))
 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
 
 (defun dfun-arg-symbol (arg-number)
-  (or (nth arg-number (the list *dfun-arg-symbols*))
+  (or (nth arg-number *dfun-arg-symbols*)
       (format-symbol *pcl-package* ".ARG~A." arg-number)))
 
+(declaim (list *slot-vector-symbols*))
 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
 
 (defun slot-vector-symbol (arg-number)
-  (or (nth arg-number (the list *slot-vector-symbols*))
+  (or (nth arg-number *slot-vector-symbols*)
       (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
 
-;; FIXME: There ought to be a good way to factor out the idiom:
-;;
-;; (dotimes (i (length metatypes))
-;;   (push (dfun-arg-symbol i) lambda-list))
-;;
-;; used in the following four functions into common code that we can
-;; declare inline or something.  --njf 2001-12-20
+(declaim (inline make-dfun-required-args))
+(defun make-dfun-required-args (metatypes)
+  ;; Micro-optimizations 'R Us
+  (labels ((rec (types i)
+             (declare (fixnum i))
+             (when types
+               (cons (dfun-arg-symbol i)
+                     (rec (cdr types) (1+ i))))))
+    (rec metatypes 0)))
+
 (defun make-dfun-lambda-list (metatypes applyp)
-  (let ((lambda-list nil))
-    (dotimes (i (length metatypes))
-      (push (dfun-arg-symbol i) lambda-list))
-    (when applyp
-      (push '&rest lambda-list)
-      (push '.dfun-rest-arg. lambda-list))
-    (nreverse lambda-list)))
+  (let ((required (make-dfun-required-args metatypes)))
+    (if applyp
+        (nconc required
+               ;; Use &MORE arguments to avoid consing up an &REST list
+               ;; that we might not need at all. See MAKE-EMF-CALL and
+               ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
+               ;; pieces.
+               '(&more .dfun-more-context. .dfun-more-count.))
+      required)))
 
 (defun make-dlap-lambda-list (metatypes applyp)
-  (let ((lambda-list nil))
-    (dotimes (i (length metatypes))
-      (push (dfun-arg-symbol i) lambda-list))
-    ;; FIXME: This is translated directly from the old PCL code.
-    ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or
-    ;; something similar, so we don't either.  It's hard to see how
-    ;; this could be correct, since &REST wants an argument after
-    ;; it.  This function works correctly because the caller
-    ;; magically tacks on something after &REST.  The calling functions
-    ;; (in dlisp.lisp) should be fixed and this function rewritten.
-    ;; --njf 2001-12-20
-    (when applyp
-      (push '&rest lambda-list))
-    (nreverse lambda-list)))
-
-;; FIXME: The next two functions suffer from having a `.DFUN-REST-ARG.'
-;; in their lambda lists, but no corresponding `&REST' symbol.  We assume
-;; this should be the case by analogy with the previous two functions.
-;; It works, and I don't know why.  Check the calling functions and
-;; fix these too.  --njf 2001-12-20
+  (let* ((required (make-dfun-required-args metatypes))
+         (lambda-list (if applyp
+                          (append required '(&more .more-context. .more-count.))
+                          required)))
+    ;; Return the full lambda list, the required arguments, a form
+    ;; that will generate a rest-list, and a list of the &MORE
+    ;; parameters used.
+    (values lambda-list
+            required
+            (when applyp
+              '((sb-c::%listify-rest-args
+                 .more-context.
+                 (the (and unsigned-byte fixnum)
+                   .more-count.))))
+            (when applyp
+              '(.more-context. .more-count.)))))
+
 (defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
-  (let ((required
-         (let ((required nil))
-           (dotimes (i (length metatypes))
-             (push (dfun-arg-symbol i) required))
-           (nreverse required))))
+  (let ((required (make-dfun-required-args metatypes)))
     `(,(if (eq emf-type 'fast-method-call)
            'invoke-effective-method-function-fast
            'invoke-effective-method-function)
-      ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
+       ,fn-variable
+       ,applyp
+       :required-args ,required
+       ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
+       ;; the :REST-ARG version or the :MORE-ARG version depending on
+       ;; the type of the EMF.
+       :rest-arg ,(if applyp
+                      ;; Creates a list from the &MORE arguments.
+                      '((sb-c::%listify-rest-args
+                         .dfun-more-context.
+                         (the (and unsigned-byte fixnum)
+                           .dfun-more-count.)))
+                      nil)
+       :more-arg ,(when applyp
+                    '(.dfun-more-context. .dfun-more-count.)))))
 
 (defun make-fast-method-call-lambda-list (metatypes applyp)
-  (let ((reversed-lambda-list nil))
-    (push '.pv-cell. reversed-lambda-list)
-    (push '.next-method-call. reversed-lambda-list)
-    (dotimes (i (length metatypes))
-      (push (dfun-arg-symbol i) reversed-lambda-list))
-    (when applyp
-      (push '.dfun-rest-arg. reversed-lambda-list))
-    (nreverse reversed-lambda-list)))
+  (list* '.pv-cell. '.next-method-call.
+         (make-dfun-lambda-list metatypes applyp)))
+
 
 (defmacro with-local-cache-functions ((cache) &body body)
   `(let ((.cache. ,cache))
@@ -737,7 +735,7 @@
      (labels ((cache () .cache.)
               (nkeys () (cache-nkeys .cache.))
               (line-size () (cache-line-size .cache.))
-              (vector () (cache-vector .cache.))
+              (c-vector () (cache-vector .cache.))
               (valuep () (cache-valuep .cache.))
               (nlines () (cache-nlines .cache.))
               (max-location () (cache-max-location .cache.))
@@ -798,9 +796,9 @@
               (location-wrappers (location) ; avoid multiplies caused by line-location
                 (declare (fixnum location))
                 (if (= (nkeys) 1)
-                    (cache-vector-ref (vector) location)
+                    (cache-vector-ref (c-vector) location)
                     (let ((list (make-list (nkeys)))
-                          (vector (vector)))
+                          (vector (c-vector)))
                       (declare (simple-vector vector))
                       (dotimes (i (nkeys) list)
                         (declare (fixnum i))
@@ -818,7 +816,7 @@
               ;;
               (location-matches-wrappers-p (loc wrappers) ; must not be reserved
                 (declare (fixnum loc))
-                (let ((cache-vector (vector)))
+                (let ((cache-vector (c-vector)))
                   (declare (simple-vector cache-vector))
                   (if (= (nkeys) 1)
                       (eq wrappers (cache-vector-ref cache-vector loc))
@@ -840,14 +838,14 @@
               (location-value (loc)
                 (declare (fixnum loc))
                 (and (valuep)
-                     (cache-vector-ref (vector) (+ loc (nkeys)))))
+                     (cache-vector-ref (c-vector) (+ loc (nkeys)))))
               ;;
               ;; Given a line number, return true IFF that line has data in
               ;; it.  The state of the wrappers stored in the line is not
               ;; checked.  An error is signalled if line is reserved.
               (line-full-p (line)
                 (when (line-reserved-p line) (error "Line is reserved."))
-                (not (null (cache-vector-ref (vector) (line-location line)))))
+                (not (null (cache-vector-ref (c-vector) (line-location line)))))
               ;;
               ;; Given a line number, return true IFF the line is full and
               ;; there are no invalid wrappers in the line, and the line's
@@ -861,7 +859,7 @@
               ;;
               (location-valid-p (loc wrappers)
                 (declare (fixnum loc))
-                (let ((cache-vector (vector))
+                (let ((cache-vector (c-vector))
                       (wrappers-mismatch-p (null wrappers)))
                   (declare (simple-vector cache-vector))
                   (dotimes (i (nkeys) wrappers-mismatch-p)
@@ -920,7 +918,7 @@
                 (declare (fixnum line))
                 (compute-primary-cache-location-from-location
                  (cache) (line-location line))))
-       (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep
+       (declare (ignorable #'cache #'nkeys #'line-size #'c-vector #'valuep
                            #'nlines #'max-location #'limit-fn #'size
                            #'mask #'field #'overflow #'line-reserved-p
                            #'location-reserved-p #'line-location
@@ -953,7 +951,6 @@
 (defun fill-cache (cache wrappers value)
   ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
   (aver wrappers)
-
   (or (fill-cache-p nil cache wrappers value)
       (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*))
               (if (= (cache-nkeys cache) 1)
@@ -990,7 +987,6 @@
         (setq location (next-location location))))))
 
 (defun probe-cache (cache wrappers &optional default limit-fn)
-  ;;(declare (values value))
   (aver wrappers)
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
@@ -1016,7 +1012,8 @@
         (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
           (let ((value (funcall function (line-wrappers i) (line-value i))))
             (when set-p
-              (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
+              ;; FIXME: Cache modification: should we not be holding a lock?
+              (setf (cache-vector-ref (c-vector) (+ (line-location i) (nkeys)))
                     value)))))
       (dolist (entry (overflow))
         (let ((value (funcall function (car entry) (cdr entry))))
@@ -1042,6 +1039,8 @@
           (return t))))))
 
 ;;; returns T or NIL
+;;;
+;;; FIXME: Deceptive name as this has side-effects.
 (defun fill-cache-p (forcep cache wrappers value)
   (with-local-cache-functions (cache)
     (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
@@ -1060,14 +1059,16 @@
           (when (not emptyp)
             (push (cons (line-wrappers free) (line-value free))
                   (cache-overflow cache)))
-          ;;(fill-line free wrappers value)
+          ;; (fill-line free wrappers value)
           (let ((line free))
             (declare (fixnum line))
             (when (line-reserved-p line)
               (error "attempt to fill a reserved line"))
             (let ((loc (line-location line))
-                  (cache-vector (vector)))
+                  (cache-vector (c-vector)))
               (declare (fixnum loc) (simple-vector cache-vector))
+              ;; FIXME: Cache modifications: should we not be holding
+              ;; a lock?
               (cond ((= (nkeys) 1)
                      (setf (cache-vector-ref cache-vector loc) wrappers)
                      (when (valuep)
@@ -1083,6 +1084,7 @@
                              value))))
               (maybe-check-cache cache))))))))
 
+;;; FIXME: Deceptive name as this has side-effects
 (defun fill-cache-from-cache-p (forcep cache from-cache from-line)
   (declare (fixnum from-line))
   (with-local-cache-functions (cache)
@@ -1098,7 +1100,7 @@
                   (cache-overflow cache)))
           ;;(transfer-line from-cache-vector from-line cache-vector free)
           (let ((from-cache-vector (cache-vector from-cache))
-                (to-cache-vector (vector))
+                (to-cache-vector (c-vector))
                 (to-line free))
             (declare (fixnum to-line))
             (if (line-reserved-p to-line)
@@ -1228,7 +1230,7 @@
          ;;Copy from line to dline (dline is known to be free).
          (let ((from-loc (line-location line))
                (to-loc (line-location dline))
-               (cache-vector (vector)))
+               (cache-vector (c-vector)))
            (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
            (modify-cache cache-vector
                          (dotimes-fixnum (i (line-size))
@@ -1246,4 +1248,3 @@
     ((1 2 4) 1)
     ((8 16)  4)
     (otherwise 6)))
-