0.9.15.17:
[sbcl.git] / src / pcl / vector.lisp
1 ;;;; permutation vectors
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
6 ;;;; This software is derived from software originally released by Xerox
7 ;;;; Corporation. Copyright and release statements follow. Later modifications
8 ;;;; to the software are in the public domain and are provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; information.
11
12 ;;;; copyright information from original PCL sources:
13 ;;;;
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
16 ;;;;
17 ;;;; Use and copying of this software and preparation of derivative works based
18 ;;;; upon this software are permitted. Any distribution of this software or
19 ;;;; derivative works must comply with all applicable United States export
20 ;;;; control laws.
21 ;;;;
22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
23 ;;;; warranty about the software, its performance or its conformity to any
24 ;;;; specification.
25
26 (in-package "SB-PCL")
27 \f
28 (defmacro instance-slot-index (wrapper slot-name)
29   `(let ((pos 0))
30      (declare (fixnum pos))
31      (block loop
32        (dolist (sn (wrapper-instance-slots-layout ,wrapper))
33          (when (eq ,slot-name sn) (return-from loop pos))
34          (incf pos)))))
35 \f
36 (defun pv-cache-limit-fn (nlines)
37   (default-limit-fn nlines))
38
39 (defstruct (pv-table (:predicate pv-tablep)
40                      (:constructor make-pv-table-internal
41                                    (slot-name-lists call-list))
42                      (:copier nil))
43   (cache nil :type (or cache null))
44   (pv-size 0 :type fixnum)
45   (slot-name-lists nil :type list)
46   (call-list nil :type list))
47
48 #-sb-fluid (declaim (sb-ext:freeze-type pv-table))
49
50 ;;; FIXME: The comment below seem to indicate that this was intended
51 ;;; to be actually used, however, it isn't anymore, and was commented
52 ;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that
53 ;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18
54 ;;;
55 ;;;   help new slot-value-using-class methods affect fast iv access
56 ;;;
57 ;;;  (defvar *all-pv-table-list* nil)
58
59 (declaim (inline make-pv-table))
60 (defun make-pv-table (&key slot-name-lists call-list)
61   (make-pv-table-internal slot-name-lists call-list))
62
63 (defun make-pv-table-type-declaration (var)
64   `(type pv-table ,var))
65
66 (defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
67 (defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
68
69 ;;; Entries in this are lists of (table . pv-offset-list).
70 (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
71
72 (defun intern-pv-table (&key slot-name-lists call-list)
73   (let ((new-p nil))
74     (flet ((inner (x)
75              (or (gethash x *slot-name-lists-inner*)
76                  (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
77            (outer (x)
78              (or (gethash x *slot-name-lists-outer*)
79                  (setf (gethash x *slot-name-lists-outer*)
80                        (let ((snl (copy-list (cdr x)))
81                              (cl (car x)))
82                          (setq new-p t)
83                          (make-pv-table :slot-name-lists snl
84                                         :call-list cl))))))
85       (let ((pv-table
86              (outer (mapcar #'inner (cons call-list slot-name-lists)))))
87         (when new-p
88           (let ((pv-index 0))
89             (dolist (slot-name-list slot-name-lists)
90               (dolist (slot-name (cdr slot-name-list))
91                 (note-pv-table-reference slot-name pv-index pv-table)
92                 (incf pv-index)))
93             (dolist (gf-call call-list)
94               (note-pv-table-reference gf-call pv-index pv-table)
95               (incf pv-index))
96             (setf (pv-table-pv-size pv-table) pv-index)))
97         pv-table))))
98
99 (defun note-pv-table-reference (ref pv-offset pv-table)
100   (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
101     (when (listp entry)
102       (let ((table-entry (assq pv-table entry)))
103         (when (and (null table-entry)
104                    (> (length entry) 8))
105           (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
106             (dolist (table-entry entry)
107               (setf (gethash (car table-entry) new-table-table)
108                     (cdr table-entry)))
109             (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
110         (when (listp entry)
111           (if (null table-entry)
112               (let ((new (cons pv-table pv-offset)))
113                 (if (consp entry)
114                     (push new (cdr entry))
115                     (setf (gethash ref *pv-key-to-pv-table-table*)
116                           (list new))))
117               (push pv-offset (cdr table-entry)))
118           (return-from note-pv-table-reference nil))))
119     (let ((list (gethash pv-table entry)))
120       (if (consp list)
121           (push pv-offset (cdr list))
122           (setf (gethash pv-table entry) (list pv-offset)))))
123   nil)
124
125 (defun map-pv-table-references-of (ref function)
126   (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
127     (if (listp entry)
128         (dolist (table+pv-offset-list entry)
129           (funcall function
130                    (car table+pv-offset-list)
131                    (cdr table+pv-offset-list)))
132         (maphash function entry)))
133   ref)
134 \f
135 (defun optimize-slot-value-by-class-p (class slot-name type)
136   (or (not (eq *boot-state* 'complete))
137       (let ((slotd (find-slot-definition class slot-name)))
138         (and slotd
139              (slot-accessor-std-p slotd type)))))
140
141 (defun compute-pv-slot (slot-name wrapper class class-slots)
142   (if (symbolp slot-name)
143       (when (optimize-slot-value-by-class-p class slot-name 'all)
144         (or (instance-slot-index wrapper slot-name)
145             (assq slot-name class-slots)))
146       (when (consp slot-name)
147         (case (first slot-name)
148           ((reader writer)
149            (when (eq *boot-state* 'complete)
150              (let ((gf (gdefinition (second slot-name))))
151                (when (generic-function-p gf)
152                  (accessor-values1 gf (first slot-name) class)))))
153           (t (bug "Don't know how to deal with ~S in ~S"
154                   slot-name 'compute-pv-slots))))))
155
156 (defun compute-pv (slot-name-lists wrappers)
157   (unless (listp wrappers)
158     (setq wrappers (list wrappers)))
159   (let (elements)
160     (dolist (slot-names slot-name-lists
161              (make-permutation-vector (nreverse elements)))
162       (when slot-names
163         (let* ((wrapper (pop wrappers))
164                (std-p (typep wrapper 'wrapper))
165                (class (wrapper-class* wrapper))
166                (class-slots (and std-p (wrapper-class-slots wrapper))))
167           (dolist (slot-name (cdr slot-names))
168             (push (if std-p
169                       (compute-pv-slot slot-name wrapper class class-slots)
170                       nil)
171                   elements)))))))
172
173 (defun compute-calls (call-list wrappers)
174   (declare (ignore call-list wrappers))
175   #||
176   (map 'vector
177        (lambda (call)
178          (compute-emf-from-wrappers call wrappers))
179        call-list)
180   ||#
181   '#())
182
183 #|| ; Need to finish this, then write the maintenance functions.
184 (defun compute-emf-from-wrappers (call wrappers)
185   (when call
186     (destructuring-bind (gf-name nreq restp arg-info) call
187       (if (eq gf-name 'make-instance)
188           (error "should not get here") ; there is another mechanism for this.
189           (lambda (&rest args)
190             (if (not (eq *boot-state* 'complete))
191                 (apply (gdefinition gf-name) args)
192                 (let* ((gf (gdefinition gf-name))
193                        (arg-info (arg-info-reader gf))
194                        (classes '?)
195                        (types '?)
196                        (emf (cache-miss-values-internal gf arg-info
197                                                         wrappers classes types
198                                                         'caching)))
199                   (update-all-pv-tables call wrappers emf)
200                   (invoke-emf emf args))))))))
201 ||#
202
203 (defun make-permutation-vector (indexes)
204   (make-array (length indexes) :initial-contents indexes))
205
206 (defun pv-table-lookup (pv-table pv-wrappers)
207   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
208          (call-list (pv-table-call-list pv-table))
209          (cache (or (pv-table-cache pv-table)
210                     (setf (pv-table-cache pv-table)
211                           (get-cache (- (length slot-name-lists)
212                                         (count nil slot-name-lists))
213                                      t
214                                      #'pv-cache-limit-fn
215                                      2)))))
216     (or (probe-cache cache pv-wrappers)
217         (let* ((pv (compute-pv slot-name-lists pv-wrappers))
218                (calls (compute-calls call-list pv-wrappers))
219                (pv-cell (cons pv calls))
220                (new-cache (fill-cache cache pv-wrappers pv-cell)))
221           (unless (eq new-cache cache)
222             (setf (pv-table-cache pv-table) new-cache))
223           pv-cell))))
224
225 (defun make-pv-type-declaration (var)
226   `(type simple-vector ,var))
227
228 (defmacro pvref (pv index)
229   `(svref ,pv ,index))
230
231 (defmacro copy-pv (pv)
232   `(copy-seq ,pv))
233
234 (defun make-calls-type-declaration (var)
235   `(type simple-vector ,var))
236
237 (defmacro callsref (calls index)
238   `(svref ,calls ,index))
239
240 (defvar *pv-table-cache-update-info* nil)
241
242 (defun update-pv-table-cache-info (class)
243   (let ((slot-names-for-pv-table-update nil)
244         (new-icui nil))
245     (dolist (icu *pv-table-cache-update-info*)
246       (if (eq (car icu) class)
247           (pushnew (cdr icu) slot-names-for-pv-table-update)
248           (push icu new-icui)))
249     (setq *pv-table-cache-update-info* new-icui)
250     (when slot-names-for-pv-table-update
251       (update-all-pv-table-caches class slot-names-for-pv-table-update))))
252
253 (defun update-all-pv-table-caches (class slot-names)
254   (let* ((cwrapper (class-wrapper class))
255          (std-p (typep cwrapper 'wrapper))
256          (class-slots (and std-p (wrapper-class-slots cwrapper)))
257          (new-values
258           (mapcar
259            (lambda (slot-name)
260              (cons slot-name
261                    (if std-p
262                        (compute-pv-slot slot-name cwrapper class class-slots)
263                        nil)))
264            slot-names))
265          (pv-tables nil))
266     (dolist (slot-name slot-names)
267       (map-pv-table-references-of
268        slot-name
269        (lambda (pv-table pv-offset-list)
270          (declare (ignore pv-offset-list))
271          (pushnew pv-table pv-tables))))
272     (dolist (pv-table pv-tables)
273       (let* ((cache (pv-table-cache pv-table))
274              (slot-name-lists (pv-table-slot-name-lists pv-table))
275              (pv-size (pv-table-pv-size pv-table))
276              (pv-map (make-array pv-size :initial-element nil)))
277         (let ((map-index 0) (param-index 0))
278           (dolist (slot-name-list slot-name-lists)
279             (dolist (slot-name (cdr slot-name-list))
280               (let ((a (assoc slot-name new-values)))
281                 (setf (svref pv-map map-index)
282                       (and a (cons param-index (cdr a)))))
283               (incf map-index))
284             (incf param-index)))
285         (when cache
286           (map-cache (lambda (wrappers pv-cell)
287                        (update-slots-in-pv wrappers (car pv-cell)
288                                            cwrapper pv-size pv-map))
289                      cache))))))
290
291 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
292   (if (atom wrappers)
293       (when (eq cwrapper wrappers)
294         (dotimes-fixnum (i pv-size)
295           (let ((map (svref pv-map i)))
296             (when map
297               (aver (= (car map) 0))
298               (setf (pvref pv i) (cdr map))))))
299       (when (memq cwrapper wrappers)
300         (let ((param 0))
301           (dolist (wrapper wrappers)
302             (when (eq wrapper cwrapper)
303               (dotimes-fixnum (i pv-size)
304                 (let ((map (svref pv-map i)))
305                   (when (and map (= (car map) param))
306                     (setf (pvref pv i) (cdr map))))))
307             (incf param))))))
308 \f
309 (defun maybe-expand-accessor-form (form required-parameters slots env)
310   (let* ((fname (car form))
311          #||(len (length form))||#
312          (gf (if (symbolp fname)
313                  (unencapsulated-fdefinition fname)
314                  (gdefinition fname))))
315     (macrolet ((maybe-optimize-reader ()
316                  `(let ((parameter
317                          (can-optimize-access1 (cadr form)
318                                                required-parameters env)))
319                    (when parameter
320                      (optimize-reader slots parameter gf-name form))))
321                (maybe-optimize-writer ()
322                  `(let ((parameter
323                          (can-optimize-access1 (caddr form)
324                                                required-parameters env)))
325                    (when parameter
326                      (optimize-writer slots parameter gf-name form)))))
327       (unless (and (consp (cadr form))
328                    (eq 'instance-accessor-parameter (caadr form)))
329         (when (and (eq *boot-state* 'complete)
330                    (generic-function-p gf))
331           (let ((methods (generic-function-methods gf)))
332             (when methods
333               (let* ((gf-name (generic-function-name gf))
334                      (arg-info (gf-arg-info gf))
335                      (metatypes (arg-info-metatypes arg-info))
336                      (nreq (length metatypes))
337                      (applyp (arg-info-applyp arg-info)))
338                 (when (null applyp)
339                   (cond ((= nreq 1)
340                          (when (some #'standard-reader-method-p methods)
341                            (maybe-optimize-reader)))
342                         ((and (= nreq 2)
343                               (consp gf-name)
344                               (eq (car gf-name) 'setf))
345                          (when (some #'standard-writer-method-p methods)
346                            (maybe-optimize-writer)))))))))))))
347
348 (defun optimize-generic-function-call (form
349                                        required-parameters
350                                        env
351                                        slots
352                                        calls)
353   (declare (ignore required-parameters env slots calls))
354   (or ; (optimize-reader ...)?
355       form))
356 \f
357 (defun can-optimize-access (form required-parameters env)
358   (let ((type (ecase (car form)
359                 (slot-value 'reader)
360                 (set-slot-value 'writer)
361                 (slot-boundp 'boundp)))
362         (var (cadr form))
363         (slot-name (eval (caddr form)))) ; known to be constant
364     (can-optimize-access1 var required-parameters env type slot-name)))
365
366 ;;; FIXME: This looks like an internal helper function for
367 ;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
368 ;;; bare from several places in the code. Perhaps the two functions
369 ;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
370 ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
371 ;;; args instead of optional ones, too.
372 (defun can-optimize-access1 (var required-parameters env
373                              &optional type slot-name)
374   (when (and (consp var) (eq 'the (car var)))
375     ;; FIXME: We should assert list of length 3 here. Or maybe we
376     ;; should just define EXTRACT-THE, replace the whole
377     ;;   (WHEN ..)
378     ;; form with
379     ;;   (AWHEN (EXTRACT-THE VAR)
380     ;;     (SETF VAR IT))
381     ;; and then use EXTRACT-THE similarly to clean up the other tests
382     ;; against 'THE scattered through the PCL code.
383     (setq var (caddr var)))
384   (when (symbolp var)
385     (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
386            (parameter-or-nil (car (memq (or rebound? var)
387                                         required-parameters))))
388       (when parameter-or-nil
389         (let* ((class-name (caddr (var-declaration '%class
390                                                    parameter-or-nil
391                                                    env)))
392                (class (find-class class-name nil)))
393           (when (or (not (eq *boot-state* 'complete))
394                     (and class (not (class-finalized-p class))))
395             (setq class nil))
396           (when (and class-name (not (eq class-name t)))
397             (when (or (null type)
398                       (not (and class
399                                 (memq *the-class-structure-object*
400                                       (class-precedence-list class))))
401                       (optimize-slot-value-by-class-p class slot-name type))
402               (cons parameter-or-nil (or class class-name)))))))))
403
404 (defun optimize-slot-value (slots sparameter form)
405   (if sparameter
406       (destructuring-bind (ignore1 ignore2 slot-name-form) form
407         (declare (ignore ignore1 ignore2))
408         (let ((slot-name (eval slot-name-form)))
409           (optimize-instance-access slots :read sparameter slot-name nil)))
410       `(accessor-slot-value ,@(cdr form))))
411
412 (defun optimize-set-slot-value (slots sparameter form)
413   (if sparameter
414       (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
415         (declare (ignore ignore1 ignore2))
416         (let ((slot-name (eval slot-name-form)))
417           (optimize-instance-access slots
418                                     :write
419                                     sparameter
420                                     slot-name
421                                     new-value)))
422       `(accessor-set-slot-value ,@(cdr form))))
423
424 (defun optimize-slot-boundp (slots sparameter form)
425   (if sparameter
426       (destructuring-bind
427           ;; FIXME: In CMU CL ca. 19991205, this binding list had a
428           ;; fourth element in it, NEW-VALUE. It's hard to see how
429           ;; that could possibly be right, since SLOT-BOUNDP has no
430           ;; NEW-VALUE. Since it was causing a failure in building PCL
431           ;; for SBCL, so I changed it to match the definition of
432           ;; SLOT-BOUNDP (and also to match the list used in the
433           ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded
434           ;; out by this, since this is old code which has worked for
435           ;; ages to build PCL for CMU CL, so it's hard to see why it
436           ;; should need a patch like this in order to build PCL for
437           ;; SBCL. I'd like to return to this and find a test case
438           ;; which exercises this function both in CMU CL, to see
439           ;; whether it's really a previously-unexercised bug or
440           ;; whether I've misunderstood something (and, presumably,
441           ;; patched it wrong).
442           (slot-boundp-symbol instance slot-name-form)
443           form
444         (declare (ignore slot-boundp-symbol instance))
445         (let ((slot-name (eval slot-name-form)))
446           (optimize-instance-access slots
447                                     :boundp
448                                     sparameter
449                                     slot-name
450                                     nil)))
451       `(accessor-slot-boundp ,@(cdr form))))
452
453 (defun optimize-reader (slots sparameter gf-name form)
454   (if sparameter
455       (optimize-accessor-call slots :read sparameter gf-name nil)
456       form))
457
458 (defun optimize-writer (slots sparameter gf-name form)
459   (if sparameter
460       (destructuring-bind (ignore1 ignore2 new-value) form
461         (declare (ignore ignore1 ignore2))
462         (optimize-accessor-call slots :write sparameter gf-name new-value))
463       form))
464
465 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
466 ;;; of a required parameter to the function. The alist is in order, so
467 ;;; the position of an entry in the alist corresponds to the
468 ;;; argument's position in the lambda list.
469 (defun optimize-instance-access (slots
470                                  read/write
471                                  sparameter
472                                  slot-name
473                                  new-value)
474   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
475         (parameter (if (consp sparameter) (car sparameter) sparameter)))
476     (if (and (eq *boot-state* 'complete)
477              (classp class)
478              (memq *the-class-structure-object* (class-precedence-list class)))
479         (let ((slotd (find-slot-definition class slot-name)))
480           (ecase read/write
481             (:read
482              `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
483             (:write
484              `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
485                      ,parameter)
486                     ,new-value))
487             (:boundp
488              t)))
489         (let* ((parameter-entry (assq parameter slots))
490                (slot-entry      (assq slot-name (cdr parameter-entry)))
491                (position (posq parameter-entry slots))
492                (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
493           (unless parameter-entry
494             (bug "slot optimization bewilderment: O-I-A"))
495           (unless slot-entry
496             (setq slot-entry (list slot-name))
497             (push slot-entry (cdr parameter-entry)))
498           (push pv-offset-form (cdr slot-entry))
499           (ecase read/write
500             (:read
501              `(instance-read ,pv-offset-form ,parameter ,position
502                              ',slot-name ',class))
503             (:write
504              `(let ((.new-value. ,new-value))
505                 (instance-write ,pv-offset-form ,parameter ,position
506                                 ',slot-name ',class .new-value.)))
507             (:boundp
508              `(instance-boundp ,pv-offset-form ,parameter ,position
509                                ',slot-name ',class)))))))
510
511 (defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
512   (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
513          (parameter (if (consp sparameter) (car sparameter) sparameter))
514          (parameter-entry (assq parameter slots))
515          (name (case read/write
516                  (:read `(reader ,gf-name))
517                  (:write `(writer ,gf-name))))
518          (slot-entry      (assoc name (cdr parameter-entry) :test #'equal))
519          (position (posq parameter-entry slots))
520          (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
521     (unless parameter-entry
522       (error "slot optimization bewilderment: O-A-C"))
523     (unless slot-entry
524       (setq slot-entry (list name))
525       (push slot-entry (cdr parameter-entry)))
526     (push pv-offset-form (cdr slot-entry))
527     (ecase read/write
528       (:read
529        `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
530       (:write
531        `(let ((.new-value. ,new-value))
532           (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
533                            .new-value.))))))
534
535 (defvar *unspecific-arg* '..unspecific-arg..)
536
537 (defun optimize-gf-call-internal (form slots env)
538   (when (and (consp form)
539              (eq (car form) 'the))
540     (setq form (caddr form)))
541   (or (and (symbolp form)
542            (let* ((rebound? (caddr (var-declaration '%variable-rebinding
543                                                     form
544                                                     env)))
545                   (parameter-or-nil (car (assq (or rebound? form) slots))))
546              (when parameter-or-nil
547                (let* ((class-name (caddr (var-declaration 'class
548                                                           parameter-or-nil
549                                                           env))))
550                  (when (and class-name (not (eq class-name t)))
551                    (position parameter-or-nil slots :key #'car))))))
552       (if (constantp form)
553           (let ((form (constant-form-value form)))
554             (if (symbolp form)
555                 form
556                 *unspecific-arg*))
557           *unspecific-arg*)))
558
559 (defun optimize-gf-call (slots calls gf-call-form nreq restp env)
560   (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work
561     (let* ((args (cdr gf-call-form))
562            (all-args-p (eq (car gf-call-form) 'make-instance))
563            (non-required-args (nthcdr nreq args))
564            (required-args (ldiff args non-required-args))
565            (call-spec (list (car gf-call-form) nreq restp
566                             (mapcar (lambda (form)
567                                       (optimize-gf-call-internal form slots env))
568                                     (if all-args-p
569                                         args
570                                         required-args))))
571            (call-entry (assoc call-spec calls :test #'equal))
572            (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
573       (unless (some #'integerp
574                     (let ((spec-args (cdr call-spec)))
575                       (if all-args-p
576                           (ldiff spec-args (nthcdr nreq spec-args))
577                           spec-args)))
578         (return-from optimize-gf-call nil))
579       (unless call-entry
580         (setq call-entry (list call-spec))
581         (push call-entry (cdr calls)))
582       (push pv-offset-form (cdr call-entry))
583       (if (eq (car call-spec) 'make-instance)
584           `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
585           `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
586             (invoke-effective-method-function .emf. ,restp
587              ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
588
589 (define-walker-template pv-offset) ; These forms get munged by mutate slots.
590 (defmacro pv-offset (arg) arg)
591 (define-walker-template instance-accessor-parameter)
592 (defmacro instance-accessor-parameter (x) x)
593
594 ;;; It is safe for these two functions to be wrong. They just try to
595 ;;; guess what the most likely case will be.
596 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
597   (let ((class (and (constantp class-form) (constant-form-value class-form)))
598         (slot-name (and (constantp slot-name-form)
599                         (constant-form-value slot-name-form))))
600     (and (eq *boot-state* 'complete)
601          (standard-class-p class)
602          (not (eq class *the-class-t*)) ; shouldn't happen, though.
603          (let ((slotd (find-slot-definition class slot-name)))
604            (and slotd (eq :class (slot-definition-allocation slotd)))))))
605
606 (defun skip-fast-slot-access-p (class-form slot-name-form type)
607   (let ((class (and (constantp class-form) (constant-form-value class-form)))
608         (slot-name (and (constantp slot-name-form)
609                         (constant-form-value slot-name-form))))
610     (and (eq *boot-state* 'complete)
611          (standard-class-p class)
612          (not (eq class *the-class-t*)) ; shouldn't happen, though.
613          (let ((slotd (find-slot-definition class slot-name)))
614            (and slotd (skip-optimize-slot-value-by-class-p class
615                                                            slot-name
616                                                            type))))))
617
618 (defun skip-optimize-slot-value-by-class-p (class slot-name type)
619   (let ((slotd (find-slot-definition class slot-name)))
620     (and slotd
621          (eq *boot-state* 'complete)
622          (not (slot-accessor-std-p slotd type)))))
623
624 (defmacro instance-read-internal (pv slots pv-offset default &optional type)
625   (unless (member type '(nil :instance :class :default))
626     (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
627   (if (eq type :default)
628       default
629       (let* ((index (gensym))
630              (value index))
631         `(locally (declare #.*optimize-speed*)
632           (let ((,index (pvref ,pv ,pv-offset)))
633             (setq ,value (typecase ,index
634                            ;; FIXME: the line marked by KLUDGE below
635                            ;; (and the analogous spot in
636                            ;; INSTANCE-WRITE-INTERNAL) is there purely
637                            ;; to suppress a type mismatch warning that
638                            ;; propagates through to user code.
639                            ;; Presumably SLOTS at this point can never
640                            ;; actually be NIL, but the compiler seems
641                            ;; to think it could, so we put this here
642                            ;; to shut it up.  (see also mail Rudi
643                            ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
644                            ;; 2003-11-30
645                            ,@(when (or (null type) (eq type :instance))
646                                `((fixnum
647                                   (and ,slots ; KLUDGE
648                                    (clos-slots-ref ,slots ,index)))))
649                            ,@(when (or (null type) (eq type :class))
650                                `((cons (cdr ,index))))
651                            (t +slot-unbound+)))
652             (if (eq ,value +slot-unbound+)
653                 ,default
654                 ,value))))))
655
656 (defmacro instance-read (pv-offset parameter position slot-name class)
657   (if (skip-fast-slot-access-p class slot-name 'reader)
658       `(accessor-slot-value ,parameter ,slot-name)
659       `(instance-read-internal .pv. ,(slot-vector-symbol position)
660         ,pv-offset (accessor-slot-value ,parameter ,slot-name)
661         ,(if (generate-fast-class-slot-access-p class slot-name)
662              :class :instance))))
663
664 (defmacro instance-reader (pv-offset parameter position gf-name class)
665   (declare (ignore class))
666   `(instance-read-internal .pv. ,(slot-vector-symbol position)
667     ,pv-offset
668     (,gf-name (instance-accessor-parameter ,parameter))
669     :instance))
670
671 (defmacro instance-write-internal (pv slots pv-offset new-value default
672                                       &optional type)
673   (unless (member type '(nil :instance :class :default))
674     (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
675   (if (eq type :default)
676       default
677       (let* ((index (gensym)))
678         `(locally (declare #.*optimize-speed*)
679           (let ((,index (pvref ,pv ,pv-offset)))
680             (typecase ,index
681               ,@(when (or (null type) (eq type :instance))
682                   `((fixnum (and ,slots
683                              (setf (clos-slots-ref ,slots ,index)
684                                    ,new-value)))))
685               ,@(when (or (null type) (eq type :class))
686                   `((cons (setf (cdr ,index) ,new-value))))
687               (t ,default)))))))
688
689 (defmacro instance-write (pv-offset
690                           parameter
691                           position
692                           slot-name
693                           class
694                           new-value)
695   (if (skip-fast-slot-access-p class slot-name 'writer)
696       `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
697       `(instance-write-internal .pv. ,(slot-vector-symbol position)
698         ,pv-offset ,new-value
699         (accessor-set-slot-value ,parameter ,slot-name ,new-value)
700         ,(if (generate-fast-class-slot-access-p class slot-name)
701              :class :instance))))
702
703 (defmacro instance-writer (pv-offset
704                            parameter
705                            position
706                            gf-name
707                            class
708                            new-value)
709   (declare (ignore class))
710   `(instance-write-internal .pv. ,(slot-vector-symbol position)
711     ,pv-offset ,new-value
712     (,(if (consp gf-name)
713           (get-setf-fun-name gf-name)
714           gf-name)
715      (instance-accessor-parameter ,parameter)
716      ,new-value)
717     :instance))
718
719 (defmacro instance-boundp-internal (pv slots pv-offset default
720                                        &optional type)
721   (unless (member type '(nil :instance :class :default))
722     (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
723   (if (eq type :default)
724       default
725       (let* ((index (gensym)))
726         `(locally (declare #.*optimize-speed*)
727           (let ((,index (pvref ,pv ,pv-offset)))
728             (typecase ,index
729               ,@(when (or (null type) (eq type :instance))
730                   `((fixnum (not (and ,slots
731                                       (eq (clos-slots-ref ,slots ,index)
732                                           +slot-unbound+))))))
733               ,@(when (or (null type) (eq type :class))
734                   `((cons (not (eq (cdr ,index) +slot-unbound+)))))
735               (t ,default)))))))
736
737 (defmacro instance-boundp (pv-offset parameter position slot-name class)
738   (if (skip-fast-slot-access-p class slot-name 'boundp)
739       `(accessor-slot-boundp ,parameter ,slot-name)
740       `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
741         ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
742         ,(if (generate-fast-class-slot-access-p class slot-name)
743              :class :instance))))
744
745 ;;; This magic function has quite a job to do indeed.
746 ;;;
747 ;;; The careful reader will recall that <slots> contains all of the
748 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
749 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
750 ;;;
751 ;;; At the time these calls were produced, the first argument was
752 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
753 ;;; convert those pv-offset arguments into the actual number that is
754 ;;; the correct offset into the pv.
755 ;;;
756 ;;; But first, oh but first, we sort <slots> a bit so that for each
757 ;;; argument we have the slots in alphabetical order. This
758 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
759 ;;; having fewer PV's floating around. Even if the gain is only
760 ;;; modest, it costs nothing.
761 (defun slot-name-lists-from-slots (slots calls)
762   (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
763     (let* ((slot-name-lists
764             (mapcar (lambda (parameter-entry)
765                       (cons nil (mapcar #'car (cdr parameter-entry))))
766                     slots))
767            (call-list
768             (mapcar #'car calls)))
769       (dolist (call call-list)
770         (dolist (arg (cdr call))
771           (when (integerp arg)
772             (setf (car (nth arg slot-name-lists)) t))))
773       (setq slot-name-lists (mapcar (lambda (r+snl)
774                                       (when (or (car r+snl) (cdr r+snl))
775                                         r+snl))
776                                     slot-name-lists))
777       (let ((cvt (apply #'vector
778                         (let ((i -1))
779                           (mapcar (lambda (r+snl)
780                                     (when r+snl (incf i)))
781                                   slot-name-lists)))))
782         (setq call-list (mapcar (lambda (call)
783                                   (cons (car call)
784                                         (mapcar (lambda (arg)
785                                                   (if (integerp arg)
786                                                       (svref cvt arg)
787                                                       arg))
788                                                 (cdr call))))
789                                 call-list)))
790       (values slot-name-lists call-list))))
791
792 (defun mutate-slots-and-calls (slots calls)
793   (let ((sorted-slots (sort-slots slots))
794         (sorted-calls (sort-calls (cdr calls)))
795         (pv-offset -1))
796     (dolist (parameter-entry sorted-slots)
797       (dolist (slot-entry (cdr parameter-entry))
798         (incf pv-offset)
799         (dolist (form (cdr slot-entry))
800           (setf (cadr form) pv-offset))))
801     (dolist (call-entry sorted-calls)
802       (incf pv-offset)
803       (dolist (form (cdr call-entry))
804         (setf (cadr form) pv-offset)))
805     (values sorted-slots sorted-calls)))
806
807 (defun symbol-pkg-name (sym)
808   (let ((pkg (symbol-package sym)))
809     (if pkg (package-name pkg) "")))
810
811 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
812 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
813 ;;; stable. This ordering is only used in to
814 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
815 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
816 ;;; floating around", so it sounds as though the instability won't
817 ;;; actually lead to bugs, just small inefficiency. But still, it
818 ;;; would be better to reimplement this function as a comparison based
819 ;;; on SYMBOL-HASH:
820 ;;;   * stable comparison
821 ;;;   * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
822 ;;;   * faster code.
823 (defun symbol-lessp (a b)
824   (if (eq (symbol-package a)
825           (symbol-package b))
826       (string-lessp (symbol-name a)
827                     (symbol-name b))
828       (string-lessp (symbol-pkg-name a)
829                     (symbol-pkg-name b))))
830
831 (defun symbol-or-cons-lessp (a b)
832   (etypecase a
833     (symbol (etypecase b
834               (symbol (symbol-lessp a b))
835               (cons t)))
836     (cons   (etypecase b
837               (symbol nil)
838               (cons (if (eq (car a) (car b))
839                         (symbol-or-cons-lessp (cdr a) (cdr b))
840                         (symbol-or-cons-lessp (car a) (car b))))))))
841
842 (defun sort-slots (slots)
843   (mapcar (lambda (parameter-entry)
844             (cons (car parameter-entry)
845                   (sort (cdr parameter-entry)   ;slot entries
846                         #'symbol-or-cons-lessp
847                         :key #'car)))
848           slots))
849
850 (defun sort-calls (calls)
851   (sort calls #'symbol-or-cons-lessp :key #'car))
852 \f
853 ;;;; This needs to work in terms of metatypes and also needs to work
854 ;;;; for automatically generated reader and writer functions.
855 ;;;; Automatically generated reader and writer functions use this
856 ;;;; stuff too.
857
858 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
859                       &body body)
860   (let (slot-vars pv-parameters)
861     (loop for slots in slot-name-lists
862           for required-parameter in required-parameters
863           for i from 0
864           do (when slots
865                (push required-parameter pv-parameters)
866                (push (slot-vector-symbol i) slot-vars)))
867     `(pv-binding1 (.pv. .calls. ,pv-table-form
868                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
869        ,@body)))
870
871 (defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
872                        &body body)
873   `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters)
874      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
875                      slot-vars pv-parameters))
876        (declare (ignorable ,@(mapcar #'identity slot-vars)))
877        ,@body)))
878
879 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
880 ;;; overridden.
881 (define-symbol-macro pv-env-environment overridden)
882
883 (defmacro pv-env (&environment env
884                   (pv calls pv-table-form pv-parameters)
885                   &rest forms)
886   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
887   ;; symbol-macrolet.
888   (if (eq (macroexpand 'pv-env-environment env) 'default)
889       `(let ((,pv (car .pv-cell.))
890              (,calls (cdr .pv-cell.)))
891          (declare ,(make-pv-type-declaration pv)
892                   ,(make-calls-type-declaration calls))
893          ,pv ,calls
894          ,@forms)
895       `(let* ((.pv-table. ,pv-table-form)
896               (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
897               (,pv (car .pv-cell.))
898               (,calls (cdr .pv-cell.)))
899         (declare ,(make-pv-type-declaration pv))
900         (declare ,(make-calls-type-declaration calls))
901         ,pv ,calls
902         ,@forms)))
903
904 (defvar *non-var-declarations*
905   ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
906   ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
907   ;; SBCL doesn't have 'em, VALUES should probably be removed from
908   ;; this list.
909   '(values
910     %method-name
911     %method-lambda-list
912     optimize
913     ftype
914     inline
915     notinline))
916
917 (defvar *var-declarations-with-arg*
918   '(%class
919     type))
920
921 (defvar *var-declarations-without-arg*
922   '(ignore
923     ignorable special dynamic-extent
924     ;; FIXME: Possibly this entire list and variable could go away.
925     ;; If not, certainly we should remove all these built-in typenames
926     ;; from the list, and replace them with a test for "is it a type
927     ;; name?" (CLTL1 allowed only built-in type names as declarations,
928     ;; but ANSI CL allows any type name as a declaration.)
929     array atom base-char bignum bit bit-vector character compiled-function
930     complex cons double-float extended-char
931     fixnum float function hash-table integer
932     keyword list long-float nil null number package pathname random-state ratio
933     rational readtable sequence short-float signed-byte simple-array
934     simple-bit-vector simple-string simple-vector single-float standard-char
935     stream string symbol t unsigned-byte vector))
936
937 (defun split-declarations (body args maybe-reads-params-p)
938   (let ((inner-decls nil)
939         (outer-decls nil)
940         decl)
941     (loop (when (null body) (return nil))
942           (setq decl (car body))
943           (unless (and (consp decl)
944                        (eq (car decl) 'declare))
945             (return nil))
946           (dolist (form (cdr decl))
947             (when (consp form)
948               (let ((declaration-name (car form)))
949                 (if (member declaration-name *non-var-declarations*)
950                     (push `(declare ,form) outer-decls)
951                     (let ((arg-p
952                            (member declaration-name
953                                    *var-declarations-with-arg*))
954                           (non-arg-p
955                            (member declaration-name
956                                    *var-declarations-without-arg*))
957                           (dname (list (pop form)))
958                           (inners nil) (outers nil))
959                       (unless (or arg-p non-arg-p)
960                         ;; FIXME: This warning, and perhaps the
961                         ;; various *VAR-DECLARATIONS-FOO* and/or
962                         ;; *NON-VAR-DECLARATIONS* variables,
963                         ;; could probably go away now that we're not
964                         ;; trying to be portable between different
965                         ;; CLTL1 hosts the way PCL was. (Note that to
966                         ;; do this right, we need to be able to handle
967                         ;; user-defined (DECLAIM (DECLARATION FOO))
968                         ;; stuff.)
969                         (warn "The declaration ~S is not understood by ~S.~@
970                                Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
971                         (Assuming it is a variable declaration without argument)."
972                               declaration-name 'split-declarations
973                               declaration-name
974                               '*non-var-declarations*
975                               '*var-declarations-with-arg*
976                               '*var-declarations-without-arg*)
977                         (push declaration-name *var-declarations-without-arg*))
978                       (when arg-p
979                         (setq dname (append dname (list (pop form)))))
980                       (case (car dname)
981                         (%class (push `(declare (,@dname ,@form)) inner-decls))
982                         (t
983                          (dolist (var form)
984                            (if (member var args)
985                                ;; Quietly remove IGNORE declarations
986                                ;; on args when a next-method is
987                                ;; involved, to prevent compiler
988                                ;; warnings about ignored args being
989                                ;; read.
990                                (unless (and maybe-reads-params-p
991                                             (eq (car dname) 'ignore))
992                                  (push var outers))
993                                (push var inners)))
994                          (when outers
995                            (push `(declare (,@dname ,@outers)) outer-decls))
996                          (when inners
997                            (push
998                             `(declare (,@dname ,@inners))
999                             inner-decls)))))))))
1000           (setq body (cdr body)))
1001     (values outer-decls inner-decls body)))
1002
1003 ;;; Pull a name out of the %METHOD-NAME declaration in the function
1004 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
1005 (defun body-method-name (body)
1006   (multiple-value-bind (real-body declarations documentation)
1007       (parse-body body)
1008     (declare (ignore real-body documentation))
1009     (let ((name-decl (get-declaration '%method-name declarations)))
1010       (and name-decl
1011            (destructuring-bind (name) name-decl
1012              name)))))
1013
1014 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
1015 ;;; declaration (which is a naming style internal to PCL) into an
1016 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
1017 ;;; throughout SBCL, understood by the main compiler); or if there's
1018 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
1019 ;;; lambda expression.
1020 (defun name-method-lambda (method-lambda)
1021   (let ((method-name (body-method-name (cddr method-lambda))))
1022     (if method-name
1023         `(named-lambda (slow-method ,method-name) ,(rest method-lambda))
1024         method-lambda)))
1025
1026 (defun make-method-initargs-form-internal (method-lambda initargs env)
1027   (declare (ignore env))
1028   (let (method-lambda-args
1029         lmf ; becomes body of function
1030         lmf-params)
1031     (if (not (and (= 3 (length method-lambda))
1032                   (= 2 (length (setq method-lambda-args (cadr method-lambda))))
1033                   (consp (setq lmf (third method-lambda)))
1034                   (eq 'simple-lexical-method-functions (car lmf))
1035                   (eq (car method-lambda-args)
1036                       (cadr (setq lmf-params (cadr lmf))))
1037                   (eq (cadr method-lambda-args)
1038                       (caddr lmf-params))))
1039         `(list* :function ,(name-method-lambda method-lambda)
1040                 ',initargs)
1041         (let* ((lambda-list (car lmf-params))
1042                (nreq 0)
1043                (restp nil)
1044                (args nil))
1045           (dolist (arg lambda-list)
1046             (when (member arg '(&optional &rest &key))
1047               (setq restp t)
1048               (return nil))
1049             (when (eq arg '&aux)
1050               (return nil))
1051             (incf nreq)
1052             (push arg args))
1053           (setq args (nreverse args))
1054           (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp))
1055           (make-method-initargs-form-internal1
1056            initargs (cddr lmf) args lmf-params restp)))))
1057
1058 (defun make-method-initargs-form-internal1
1059     (initargs body req-args lmf-params restp)
1060   (multiple-value-bind (outer-decls inner-decls body-sans-decls)
1061       (split-declarations
1062        body req-args (or (getf (cdr lmf-params) :call-next-method-p)
1063                          (getf (cdr lmf-params) :setq-p)))
1064     (let* ((rest-arg (when restp '.rest-arg.))
1065            (args+rest-arg (if restp
1066                               (append req-args (list rest-arg))
1067                               req-args)))
1068       `(list*
1069         :function
1070         (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
1071                      ,@(when (body-method-name body)
1072                          ;; function name
1073                          (list (cons 'fast-method (body-method-name body))))
1074                      (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
1075                      ;; body of the function
1076                      (declare (ignorable .pv-cell. .next-method-call.)
1077                               (disable-package-locks pv-env-environment))
1078                      ,@outer-decls
1079                      (symbol-macrolet ((pv-env-environment default))
1080                          (fast-lexical-method-functions
1081                           (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
1082                             ,@(cdddr lmf-params))
1083                           ,@inner-decls
1084                           ,@body-sans-decls))))
1085               (mf (%make-method-function fmf nil)))
1086           (set-funcallable-instance-function
1087            mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
1088           mf)
1089         ',initargs))))
1090
1091 ;;; Use arrays and hash tables and the fngen stuff to make this much
1092 ;;; better. It doesn't really matter, though, because a function
1093 ;;; returned by this will get called only when the user explicitly
1094 ;;; funcalls a result of method-function. BUT, this is needed to make
1095 ;;; early methods work.
1096 (defun method-function-from-fast-function (fmf plist)
1097   (declare (type function fmf))
1098   (let* ((method-function nil)
1099          (calls (getf plist :call-list))
1100          (snl (getf plist :slot-name-lists))
1101          (pv-table (when (or calls snl)
1102                      (intern-pv-table :call-list calls :slot-name-lists snl)))
1103          (arg-info (getf plist :arg-info))
1104          (nreq (car arg-info))
1105          (restp (cdr arg-info)))
1106     (setq method-function
1107           (lambda (method-args next-methods)
1108             (let* ((pv-cell (when pv-table
1109                               (get-pv-cell method-args pv-table)))
1110                    (nm (car next-methods))
1111                    (nms (cdr next-methods))
1112                    (nmc (when nm
1113                           (make-method-call
1114                            :function (if (std-instance-p nm)
1115                                          (method-function nm)
1116                                          nm)
1117                            :call-method-args (list nms)))))
1118               (if restp
1119                   (let* ((rest (nthcdr nreq method-args))
1120                          (args (ldiff method-args rest)))
1121                     (apply fmf pv-cell nmc (nconc args (list rest))))
1122                   (apply fmf pv-cell nmc method-args)))))
1123     ;; FIXME: this looks dangerous.
1124     (let* ((fname (%fun-name fmf)))
1125       (when (and fname (eq (car fname) 'fast-method))
1126         (set-fun-name method-function (cons 'slow-method (cdr fname)))))
1127     method-function))
1128
1129 ;;; this is similar to the above, only not quite.  Only called when
1130 ;;; the MOP is heavily involved.  Not quite parallel to
1131 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
1132 ;;; over the actual PV-CELL in this case.
1133 (defun method-function-from-fast-method-call (fmc)
1134   (let* ((fmf (fast-method-call-function fmc))
1135          (pv-cell (fast-method-call-pv-cell fmc))
1136          (arg-info (fast-method-call-arg-info fmc))
1137          (nreq (car arg-info))
1138          (restp (cdr arg-info)))
1139     (lambda (method-args next-methods)
1140       (let* ((nm (car next-methods))
1141              (nms (cdr next-methods))
1142              (nmc (when nm
1143                     (make-method-call
1144                      :function (if (std-instance-p nm)
1145                                    (method-function nm)
1146                                    nm)
1147                      :call-method-args (list nms)))))
1148         (if restp
1149             (let* ((rest (nthcdr nreq method-args))
1150                    (args (ldiff method-args rest)))
1151               (apply fmf pv-cell nmc (nconc args (list rest))))
1152             (apply fmf pv-cell nmc method-args))))))
1153
1154 (defun get-pv-cell (method-args pv-table)
1155   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
1156     (when pv-wrappers
1157       (pv-table-lookup pv-table pv-wrappers))))
1158
1159 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
1160   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
1161
1162 (defun pv-wrappers-from-pv-args (&rest args)
1163   (let (wrappers)
1164     (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
1165       (let ((wrapper (wrapper-of arg)))
1166         (push (if (invalid-wrapper-p wrapper)
1167                   (check-wrapper-validity wrapper)
1168                   wrapper)
1169               wrappers)))))
1170
1171 (defun pv-wrappers-from-all-args (pv-table args)
1172   (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
1173         when snl
1174           collect (wrapper-of arg) into wrappers
1175         finally (return (if (cdr wrappers) wrappers (car wrappers)))))
1176
1177 ;;; Return the subset of WRAPPERS which is used in the cache
1178 ;;; of PV-TABLE.
1179 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
1180   (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
1181         when snl
1182           collect w into result
1183         finally (return (if (cdr result) result (car result)))))