1.0.9.43: .PV-CELL., use .PV. directly

* Now that .CALLS. are gone we can get rid of the extra indirection.
  (Maybe we have to add it back later, but worry about that then.)

* Since .PV. is magical, also localize its bindings to vector.lisp,
  instead of exposing the variable in PV-BINDING1's interface (which
  is used elsewhere as well.)

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index da64a23..bfa56ce 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -1015,7 +1015,7 @@ bootstrapping.
 
 (defstruct (fast-method-call (:copier nil))
   (function #'identity :type function)
-  pv-cell
+  pv
   next-method-call
   arg-info)
 (defstruct (constant-fast-method-call
@@ -1032,7 +1032,7 @@ bootstrapping.
 
 (defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
   `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
-                                (fast-method-call-pv-cell ,method-call)
+                                (fast-method-call-pv ,method-call)
                                 (fast-method-call-next-method-call ,method-call)
                                 ,@required-args+rest-arg))
 
@@ -1042,7 +1042,7 @@ bootstrapping.
                                         &rest required-args)
   (macrolet ((generate-call (n)
                ``(funcall (fast-method-call-function ,method-call)
-                          (fast-method-call-pv-cell ,method-call)
+                          (fast-method-call-pv ,method-call)
                           (fast-method-call-next-method-call ,method-call)
                           ,@required-args
                           ,@(loop for x below ,n
@@ -1056,7 +1056,7 @@ bootstrapping.
        (0 ,(generate-call 0))
        (1 ,(generate-call 1))
        (t (multiple-value-call (fast-method-call-function ,method-call)
-            (values (fast-method-call-pv-cell ,method-call))
+            (values (fast-method-call-pv ,method-call))
             (values (fast-method-call-next-method-call ,method-call))
             ,@required-args
             (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
@@ -1204,7 +1204,7 @@ bootstrapping.
             (nreq (car arg-info)))
        (if restp
            (apply (fast-method-call-function emf)
-                  (fast-method-call-pv-cell emf)
+                  (fast-method-call-pv emf)
                   (fast-method-call-next-method-call emf)
                   args)
            (cond ((null args)
@@ -1227,7 +1227,7 @@ bootstrapping.
                              :format-arguments nil)))
                  (t
                   (apply (fast-method-call-function emf)
-                         (fast-method-call-pv-cell emf)
+                         (fast-method-call-pv emf)
                          (fast-method-call-next-method-call emf)
                          args))))))
     (method-call

diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp
index b6a0fc1..ecd09d5 100644 (file)
--- a/src/pcl/combin.lisp
+++ b/src/pcl/combin.lisp
@@ -36,9 +36,9 @@
                 (let* ((pv-wrappers (when pv-table
                                       (pv-wrappers-from-all-wrappers
                                        pv-table wrappers)))
-                       (pv-cell (when (and pv-table pv-wrappers)
-                                  (pv-table-lookup pv-table pv-wrappers))))
-                  (values mf t fmf pv-cell))
+                       (pv (when (and pv-table pv-wrappers)
+                             (pv-table-lookup pv-table pv-wrappers))))
+                  (values mf t fmf pv))
                 (values
                  (or mf (if (listp method)
                             (bug "early method with no method-function")
@@ -120,7 +120,7 @@
 
 (defun make-emf-from-method
     (method cm-args &optional gf fmf-p method-alist wrappers)
-  (multiple-value-bind (mf real-mf-p fmf pv-cell)
+  (multiple-value-bind (mf real-mf-p fmf pv)
       (get-method-function method method-alist wrappers)
     (if fmf
         (let* ((next-methods (car cm-args))
@@ -132,10 +132,10 @@
                (default (cons nil nil))
                (value (method-plist-value method :constant-value default)))
           (if (eq value default)
-              (make-fast-method-call :function fmf :pv-cell pv-cell
+              (make-fast-method-call :function fmf :pv pv
                                      :next-method-call next :arg-info arg-info)
               (make-constant-fast-method-call
-               :function fmf :pv-cell pv-cell :next-method-call next
+               :function fmf :pv pv :next-method-call next
                :arg-info arg-info :value value)))
         (if real-mf-p
             (flet ((frob-cm-arg (arg)
@@ -232,8 +232,8 @@
                     (long-method-combination-args-lambda-list combin))))))
       (cond
         (error-p
-         `(lambda (.pv-cell. .next-method-call. &rest .args.)
-           (declare (ignore .pv-cell. .next-method-call.))
+         `(lambda (.pv. .next-method-call. &rest .args.)
+           (declare (ignore .pv. .next-method-call.))
            (declare (ignorable .args.))
            (flet ((%no-primary-method (gf args)
                     (apply #'no-primary-method gf args))
@@ -251,14 +251,14 @@
                                         .dfun-more-count.)))
                              `(list ,@required))))
            `(lambda ,ll
-             (declare (ignore .pv-cell. .next-method-call.))
+             (declare (ignore .pv. .next-method-call.))
              (let ((.gf-args. ,gf-args))
                (declare (ignorable .gf-args.))
                ,@check-applicable-keywords
                ,effective-method))))
         (t
          `(lambda ,ll
-           (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+           (declare (ignore ,@(if error-p ll '(.pv. .next-method-call.))))
            ,@check-applicable-keywords
            ,effective-method))))))
 

diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp
index 030864a..27f601c 100644 (file)
--- a/src/pcl/dlisp.lisp
+++ b/src/pcl/dlisp.lisp
@@ -101,7 +101,7 @@
                     '(.dfun-more-context. .dfun-more-count.)))))
 
 (defun make-fast-method-call-lambda-list (nargs applyp)
-  (list* '.pv-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
+  (list* '.pv. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
 \f
 ;;; Emitting various accessors.
 

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 4a45c20..f8f13a7 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1360,7 +1360,7 @@
           (get-fun1 `(lambda
                       ,arglist
                       ,@(unless function-p
-                          `((declare (ignore .pv-cell. .next-method-call.))))
+                          `((declare (ignore .pv. .next-method-call.))))
                       (locally (declare #.*optimize-speed*)
                                (let ((emf ,net))
                                  ,(make-emf-call nargs applyp 'emf))))

diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 90a592b..b96dbd0 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -459,8 +459,8 @@
   (let* ((initargs (copy-tree
                     (make-method-function
                      (lambda (instance)
-                       (pv-binding1 (.pv. (bug "Please report this")
-                                          (instance) (instance-slots))
+                       (pv-binding1 ((bug "Please report this")
+                                     (instance) (instance-slots))
                          (instance-read-internal
                           .pv. instance-slots 0
                           (slot-value instance slot-name))))))))
@@ -488,15 +488,15 @@
                         (make-method-function
                          (lambda (nv instance)
                            (funcall check-fun nv instance)
-                           (pv-binding1 (.pv. (bug "Please report this")
-                                              (instance) (instance-slots))
+                           (pv-binding1 ((bug "Please report this")
+                                         (instance) (instance-slots))
                              (instance-write-internal
                               .pv. instance-slots 0 nv
                               (setf (slot-value instance slot-name) nv)))))
                         (make-method-function
                          (lambda (nv instance)
-                           (pv-binding1 (.pv. (bug "Please report this")
-                                              (instance) (instance-slots))
+                           (pv-binding1 ((bug "Please report this")
+                                         (instance) (instance-slots))
                              (instance-write-internal
                               .pv. instance-slots 0 nv
                               (setf (slot-value instance slot-name) nv)))))))))
@@ -509,8 +509,8 @@
   (let* ((initargs (copy-tree
                     (make-method-function
                      (lambda (instance)
-                       (pv-binding1 (.pv. (bug "Please report this")
-                                          (instance) (instance-slots))
+                       (pv-binding1 ((bug "Please report this")
+                                     (instance) (instance-slots))
                           (instance-boundp-internal
                            .pv. instance-slots 0
                            (slot-boundp instance slot-name))))))))

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 152eafb..ea6ea96 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -159,8 +159,7 @@
   (unless (listp wrappers)
     (setq wrappers (list wrappers)))
   (let (elements)
-    (dolist (slot-names slot-name-lists
-             (make-permutation-vector (nreverse elements)))
+    (dolist (slot-names slot-name-lists)
       (when slot-names
         (let* ((wrapper (pop wrappers))
                (std-p (typep wrapper 'wrapper))
@@ -170,10 +169,12 @@
             (push (if std-p
                       (compute-pv-slot slot-name wrapper class class-slots)
                       nil)
-                  elements)))))))
-
-(defun make-permutation-vector (indexes)
-  (make-array (length indexes) :initial-contents indexes))
+                  elements)))))
+    (let* ((n (length elements))
+           (pv (make-array n)))
+      (loop for i from (1- n) downto 0
+         do (setf (svref pv i) (pop elements)))
+      pv)))
 
 (defun pv-table-lookup (pv-table pv-wrappers)
   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
@@ -187,13 +188,12 @@
       (if hitp
           value
           (let* ((pv (compute-pv slot-name-lists pv-wrappers))
-                 (pv-cell (cons pv nil))
-                 (new-cache (fill-cache cache pv-wrappers pv-cell)))
+                 (new-cache (fill-cache cache pv-wrappers pv)))
             ;; 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)))))
+            pv)))))
 
 (defun make-pv-type-declaration (var)
   `(type simple-vector ,var))
@@ -244,8 +244,8 @@
               (incf map-index))
             (incf param-index)))
         (when cache
-          (map-cache (lambda (wrappers pv-cell)
-                       (update-slots-in-pv wrappers (car pv-cell)
+          (map-cache (lambda (wrappers pv)
+                       (update-slots-in-pv wrappers pv
                                            cwrapper pv-size pv-map))
                      cache))))))
 
@@ -647,13 +647,13 @@
           do (when slots
                (push required-parameter pv-parameters)
                (push (slot-vector-symbol i) slot-vars)))
-    `(pv-binding1 (.pv. ,pv-table-form
+    `(pv-binding1 (,pv-table-form
                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
        ,@body)))
 
-(defmacro pv-binding1 ((pv pv-table-form pv-parameters slot-vars)
+(defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars)
                        &body body)
-  `(pv-env (,pv ,pv-table-form ,pv-parameters)
+  `(pv-env (,pv-table-form ,pv-parameters)
      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
                      slot-vars pv-parameters))
        (declare (ignorable ,@(mapcar #'identity slot-vars)))
@@ -664,18 +664,15 @@
 (define-symbol-macro pv-env-environment overridden)
 
 (defmacro pv-env (&environment env
-                  (pv pv-table-form pv-parameters)
+                  (pv-table-form pv-parameters)
                   &rest forms)
   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
   ;; symbol-macrolet.
   (if (eq (macroexpand 'pv-env-environment env) 'default)
-      `(let ((,pv (car .pv-cell.)))
-         (declare ,(make-pv-type-declaration pv))
-         ,@forms)
+      `(locally ,@forms)
       `(let* ((.pv-table. ,pv-table-form)
-              (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
-              (,pv (car .pv-cell.)))
-        (declare ,(make-pv-type-declaration pv))
+              (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)))
+        (declare ,(make-pv-type-declaration '.pv.))
         ,@forms)))
 
 (defvar *non-var-declarations*
@@ -902,9 +899,9 @@
                                 ;; function name
                                 (list (cons 'fast-method (body-method-name body))))
                         ;; The lambda-list of the FMF
-                        (.pv-cell. .next-method-call. ,@fmf-lambda-list)
+                        (.pv. .next-method-call. ,@fmf-lambda-list)
                         ;; body of the function
-                        (declare (ignorable .pv-cell. .next-method-call.)
+                        (declare (ignorable .pv. .next-method-call.)
                                  (disable-package-locks pv-env-environment))
                         ,@outer-decls
                         (symbol-macrolet ((pv-env-environment default))
@@ -935,8 +932,8 @@
          (restp (cdr arg-info)))
     (setq method-function
           (lambda (method-args next-methods)
-            (let* ((pv-cell (when pv-table
-                              (get-pv-cell method-args pv-table)))
+            (let* ((pv (when pv-table
+                         (get-pv method-args pv-table)))
                    (nm (car next-methods))
                    (nms (cdr next-methods))
                    (nmc (when nm
@@ -945,7 +942,7 @@
                                          (method-function nm)
                                          nm)
                            :call-method-args (list nms)))))
-              (apply fmf pv-cell nmc method-args))))
+              (apply fmf pv nmc method-args))))
     ;; FIXME: this looks dangerous.
     (let* ((fname (%fun-name fmf)))
       (when (and fname (eq (car fname) 'fast-method))
@@ -958,7 +955,7 @@
 ;;; over the actual PV-CELL in this case.
 (defun method-function-from-fast-method-call (fmc)
   (let* ((fmf (fast-method-call-function fmc))
-         (pv-cell (fast-method-call-pv-cell fmc))
+         (pv (fast-method-call-pv fmc))
          (arg-info (fast-method-call-arg-info fmc))
          (nreq (car arg-info))
          (restp (cdr arg-info)))
@@ -971,9 +968,9 @@
                                    (method-function nm)
                                    nm)
                      :call-method-args (list nms)))))
-        (apply fmf pv-cell nmc method-args)))))
+        (apply fmf pv nmc method-args)))))
 
-(defun get-pv-cell (method-args pv-table)
+(defun get-pv (method-args pv-table)
   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
     (when pv-wrappers
       (pv-table-lookup pv-table pv-wrappers))))

diff --git a/version.lisp-expr b/version.lisp-expr
index ecf0f3d..ad4ce67 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.9.42"
+"1.0.9.43"