1.0.6.46: better standard-specializer-p implementation

[sbcl.git] / src / pcl / vector.lisp

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 549c5e3..5870bfe 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -33,9 +33,6 @@
          (when (eq ,slot-name sn) (return-from loop pos))
          (incf pos)))))
 \f
-(defun pv-cache-limit-fn (nlines)
-  (default-limit-fn nlines))
-
 (defstruct (pv-table (:predicate pv-tablep)
                      (:constructor make-pv-table-internal
                                    (slot-name-lists call-list))
@@ -208,19 +205,22 @@
          (call-list (pv-table-call-list pv-table))
          (cache (or (pv-table-cache pv-table)
                     (setf (pv-table-cache pv-table)
-                          (get-cache (- (length slot-name-lists)
-                                        (count nil slot-name-lists))
-                                     t
-                                     #'pv-cache-limit-fn
-                                     2)))))
-    (or (probe-cache cache pv-wrappers)
-        (let* ((pv (compute-pv slot-name-lists pv-wrappers))
-               (calls (compute-calls call-list pv-wrappers))
-               (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))
-          pv-cell))))
+                          (make-cache :key-count (- (length slot-name-lists)
+                                                    (count nil slot-name-lists))
+                                      :value t
+                                      :size 2)))))
+    (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
+      (if hitp
+          value
+          (let* ((pv (compute-pv slot-name-lists pv-wrappers))
+                 (calls (compute-calls call-list pv-wrappers))
+                 (pv-cell (cons pv calls))
+                 (new-cache (fill-cache cache pv-wrappers pv-cell)))
+            ;; This is safe: if another thread races us here the loser just
+            ;; misses the next time as well.
+            (unless (eq new-cache cache)
+              (setf (pv-table-cache pv-table) new-cache))
+            pv-cell)))))
 
 (defun make-pv-type-declaration (var)
   `(type simple-vector ,var))
@@ -811,6 +811,7 @@
     %method-lambda-list
     optimize
     ftype
+    muffle-conditions
     inline
     notinline))
 
@@ -985,12 +986,13 @@
          ;; The lambda-list used by BIND-ARGS
          (bind-list lambda-list)
          (setq-p (getf (cdr lmf-params) :setq-p))
+         (auxp (member '&aux bind-list))
          (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
     ;; Try to use the normal function call machinery instead of BIND-ARGS
-    ;; bindings the arguments, unless:
+    ;; binding the arguments, unless:
     (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
                 ;; in any case.
-                (not restp)
+                (and (not restp) (not auxp))
                 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
                 ;; list of all non-required arguments.
                 call-next-method-p)
@@ -1013,7 +1015,9 @@
                          '.rest-arg.))
              (fmf-lambda-list (if rest-arg
                                   (append req-args (list '&rest rest-arg))
-                                  lambda-list)))
+                                  (if call-next-method-p
+                                      req-args
+                                      lambda-list))))
         `(list*
           :function
           (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
@@ -1091,11 +1095,7 @@
                                    (method-function nm)
                                    nm)
                      :call-method-args (list nms)))))
-        (if restp
-            (let* ((rest (nthcdr nreq method-args))
-                   (args (ldiff method-args rest)))
-              (apply fmf pv-cell nmc (nconc args (list rest))))
-            (apply fmf pv-cell nmc method-args))))))
+        (apply fmf pv-cell nmc method-args)))))
 
 (defun get-pv-cell (method-args pv-table)
   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))