Fix make-array transforms.
[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
28 ;;;; Up to 1.0.9.24 SBCL used to have a sketched out implementation
29 ;;;; for optimizing GF calls inside method bodies using a PV approach,
30 ;;;; inherited from the original PCL. This was never completed, and
31 ;;;; was removed at that point to make the code easier to understand
32 ;;;; -- but:
33 ;;;;
34 ;;;; FIXME: It would be possible to optimize GF calls inside method
35 ;;;; bodies using permutation vectors: if all the arguments to the
36 ;;;; GF are specializers parameters, we can assign a permutation index
37 ;;;; to each such (GF . ARGS) tuple inside a method body, and use this
38 ;;;; to cache effective method functions.
39 \f
40 (declaim (inline make-pv-table))
41 (defstruct (pv-table (:predicate pv-tablep)
42                      (:copier nil))
43   (cache nil :type (or cache null))
44   (pv-size 0 :type fixnum)
45   (slot-name-lists nil :type list))
46
47 (defun make-pv-table-type-declaration (var)
48   `(type pv-table ,var))
49
50 ;;; Used for interning parts of SLOT-NAME-LISTS, as part of
51 ;;; PV-TABLE interning -- just to save space.
52 (defvar *slot-name-lists* (make-hash-table :test 'equal))
53
54 ;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS
55 ;;; used.
56 (defvar *pv-tables* (make-hash-table :test 'equal))
57
58 ;;; ...and one lock to rule them. Lock because for certain (rare)
59 ;;; cases this lock might be grabbed in the course of method dispatch
60 ;;; -- and mostly this is already under the *world-lock*
61 (defvar *pv-lock*
62   (sb-thread:make-mutex :name "pv table index lock"))
63
64 (defun intern-pv-table (&key slot-name-lists)
65   (flet ((intern-slot-names (slot-names)
66            ;; FIXME: NIL at the head of the list is a remnant from
67            ;; old purged code, that hasn't been quite cleaned up yet.
68            ;; ...but as long as we assume it is there, we may as well
69            ;; assert it.
70            (aver (not (car slot-names)))
71            (or (gethash slot-names *slot-name-lists*)
72                (setf (gethash slot-names *slot-name-lists*) slot-names)))
73          (%intern-pv-table (snl)
74            (or (gethash snl *pv-tables*)
75                (setf (gethash snl *pv-tables*)
76                      (make-pv-table :slot-name-lists snl
77                                     :pv-size (* 2 (reduce #'+ snl
78                                                           :key (lambda (slots)
79                                                                  (length (cdr slots))))))))))
80     (sb-thread:with-mutex (*pv-lock*)
81       (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
82 \f
83 (defun use-standard-slot-access-p (class slot-name type)
84   (or (not (eq **boot-state** 'complete))
85       (and (standard-class-p class)
86            (let ((slotd (find-slot-definition class slot-name)))
87              (and slotd
88                   (slot-accessor-std-p slotd type))))))
89
90 (defun slot-missing-info (class slot-name)
91   (flet ((missing (operation)
92            (lambda (object)
93              (slot-missing class object slot-name operation))))
94     (make-slot-info
95      :reader (missing 'slot-value)
96      :boundp (missing 'slot-boundp)
97      :writer (lambda (new-value object)
98                (slot-missing class object slot-name 'setf new-value)))))
99
100 (defun compute-pv (slot-name-lists wrappers)
101   (unless (listp wrappers)
102     (setq wrappers (list wrappers)))
103   (let (elements)
104     (dolist (slot-names slot-name-lists)
105       (when slot-names
106         (let* ((wrapper (pop wrappers))
107                (std-p (typep wrapper 'wrapper))
108                (class (wrapper-class* wrapper)))
109           (dolist (slot-name (cdr slot-names))
110             (let ((cell
111                    (or (find-slot-cell wrapper slot-name)
112                        (cons nil (slot-missing-info class slot-name)))))
113               (push (when (and std-p (use-standard-slot-access-p class slot-name 'all))
114                       (car cell))
115                   elements)
116               (push (or (cdr cell)
117                         (bug "No SLOT-INFO for ~S in ~S" slot-name class))
118                   elements))))))
119     (let* ((n (length elements))
120            (pv (make-array n)))
121       (loop for i from (1- n) downto 0
122          do (setf (svref pv i) (pop elements)))
123       pv)))
124
125 (defun pv-table-lookup (pv-table pv-wrappers)
126   (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
127          (cache (or (pv-table-cache pv-table)
128                     (setf (pv-table-cache pv-table)
129                           (make-cache :key-count (- (length slot-name-lists)
130                                                     (count nil slot-name-lists))
131                                       :value t
132                                       :size 2)))))
133     (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
134       (if hitp
135           value
136           (let* ((pv (compute-pv slot-name-lists pv-wrappers))
137                  (new-cache (fill-cache cache pv-wrappers pv)))
138             ;; This is safe: if another thread races us here the loser just
139             ;; misses the next time as well.
140             (unless (eq new-cache cache)
141               (setf (pv-table-cache pv-table) new-cache))
142             pv)))))
143
144 (defun make-pv-type-declaration (var)
145   `(type simple-vector ,var))
146 \f
147 ;;; Sometimes we want to finalize if we can, but it's OK if
148 ;;; we can't.
149 (defun try-finalize-inheritance (class)
150   (unless (typep class 'forward-referenced-class)
151     (when (every (lambda (super)
152                    (or (eq super class)
153                        (class-finalized-p super)
154                        (try-finalize-inheritance super)))
155                  (class-direct-superclasses class))
156       (finalize-inheritance class)
157       t)))
158
159 (defun can-optimize-access (form required-parameters env)
160   (destructuring-bind (op var-form slot-name-form &optional new-value) form
161     (let ((type (ecase op
162                   (slot-value 'reader)
163                   (set-slot-value 'writer)
164                   (slot-boundp 'boundp)))
165           (var (extract-the var-form))
166           (slot-name (constant-form-value slot-name-form env)))
167       (when (and (symbolp var) (not (var-special-p var env)))
168         (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
169                (parameter-or-nil (car (memq (or rebound? var)
170                                             required-parameters))))
171           (when parameter-or-nil
172             (let* ((class-name (caddr (var-declaration '%class
173                                                        parameter-or-nil
174                                                        env)))
175                    (class (find-class class-name nil)))
176               (cond ((not (eq **boot-state** 'complete))
177                      (setq class nil))
178                     ((and class (not (class-finalized-p class)))
179                      ;; The class itself is never forward-referenced
180                      ;; here, but its superclasses may be.
181                      (unless (try-finalize-inheritance class)
182                        (when (boundp 'sb-c:*lexenv*)
183                          (sb-c:compiler-notify
184                           "~@<Cannot optimize slot access, inheritance of ~S is not ~
185                            yet finaliable due to forward-referenced superclasses:~
186                            ~%  ~S~:@>"
187                           class form))
188                        (setf class nil))))
189               (when (and class-name (not (eq class-name t)))
190                 (when (not (and class
191                                 (memq *the-class-structure-object*
192                                       (class-precedence-list class))))
193                   (aver type)
194                   (values (cons parameter-or-nil (or class class-name))
195                           slot-name
196                           new-value))))))))))
197
198 ;;; Check whether the binding of the named variable is modified in the
199 ;;; method body.
200 (defun parameter-modified-p (parameter-name env)
201   (let ((modified-variables (%macroexpand '%parameter-binding-modified env)))
202     (memq parameter-name modified-variables)))
203
204 (defun optimize-slot-value (form slots required-parameters env)
205   (multiple-value-bind (sparameter slot-name)
206       (can-optimize-access form required-parameters env)
207     (if sparameter
208         (let ((optimized-form
209                (optimize-instance-access slots :read sparameter
210                                          slot-name nil)))
211           ;; We don't return the optimized form directly, since there's
212           ;; still a chance that we'll find out later on that the
213           ;; optimization should not have been done, for example due to
214           ;; the walker encountering a SETQ on SPARAMETER later on in
215           ;; the body [ see for example clos.impure.lisp test with :name
216           ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
217           ;; the decision until the compiler macroexpands
218           ;; OPTIMIZED-SLOT-VALUE.
219           ;;
220           ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
221           ;; this point (instead of when expanding
222           ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
223           ;; SLOTS. If that mutation isn't done during the walking,
224           ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
225           ;; form around the body, and compilation will fail.  -- JES,
226           ;; 2006-09-18
227           `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
228         `(accessor-slot-value ,@(cdr form)))))
229
230 (defmacro optimized-slot-value (form parameter-name optimized-form
231                                 &environment env)
232   ;; Either use OPTIMIZED-FORM or fall back to the safe
233   ;; ACCESSOR-SLOT-VALUE.
234   (if (parameter-modified-p parameter-name env)
235       `(accessor-slot-value ,@(cdr form))
236       optimized-form))
237
238 (defun optimize-set-slot-value (form slots required-parameters env)
239   (multiple-value-bind (sparameter slot-name new-value)
240       (can-optimize-access form required-parameters env)
241     (if sparameter
242         (let ((optimized-form
243                (optimize-instance-access slots :write sparameter
244                                          slot-name new-value (safe-code-p env))))
245              ;; See OPTIMIZE-SLOT-VALUE
246              `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form))
247            `(accessor-set-slot-value ,@(cdr form)))))
248
249 (defmacro optimized-set-slot-value (form parameter-name optimized-form
250                                     &environment env)
251   (cond ((parameter-modified-p parameter-name env)
252          ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking,
253          ;; so we need to use SAFE-SET-SLOT-VALUE.
254          (if (safe-code-p env)
255              `(safe-set-slot-value ,@(cdr form)))
256              `(accessor-set-slot-value ,@(cdr form)))
257         (t
258          optimized-form)))
259
260 (defun optimize-slot-boundp (form slots required-parameters env)
261   (multiple-value-bind (sparameter slot-name)
262       (can-optimize-access form required-parameters env)
263     (if sparameter
264         (let ((optimized-form
265                (optimize-instance-access slots :boundp sparameter
266                                          slot-name nil)))
267           ;; See OPTIMIZE-SLOT-VALUE
268           `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form))
269         `(accessor-slot-boundp ,@(cdr form)))))
270
271 (defmacro optimized-slot-boundp (form parameter-name optimized-form
272                                  &environment env)
273   (if (parameter-modified-p parameter-name env)
274       `(accessor-slot-boundp ,@(cdr form))
275       optimized-form))
276
277 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
278 ;;; of a required parameter to the function. The alist is in order, so
279 ;;; the position of an entry in the alist corresponds to the
280 ;;; argument's position in the lambda list.
281 (defun optimize-instance-access (slots read/write sparameter slot-name
282                                  new-value &optional safep)
283   (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
284         (parameter (if (consp sparameter) (car sparameter) sparameter)))
285     (if (and (eq **boot-state** 'complete)
286              (classp class)
287              (memq *the-class-structure-object* (class-precedence-list class)))
288         (let ((slotd (find-slot-definition class slot-name)))
289           (ecase read/write
290             (:read
291              `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
292             (:write
293              `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
294                      ,parameter)
295                     ,new-value))
296             (:boundp
297              t)))
298         (let* ((parameter-entry (assq parameter slots))
299                (slot-entry      (assq slot-name (cdr parameter-entry)))
300                (position (posq parameter-entry slots))
301                (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
302           (unless parameter-entry
303             (bug "slot optimization bewilderment: O-I-A"))
304           (unless slot-entry
305             (setq slot-entry (list slot-name))
306             (push slot-entry (cdr parameter-entry)))
307           (push pv-offset-form (cdr slot-entry))
308           (ecase read/write
309             (:read
310              `(instance-read ,pv-offset-form ,parameter ,position
311                              ',slot-name ',class))
312             (:write
313              `(let ((.new-value. ,new-value))
314                 (instance-write ,pv-offset-form ,parameter ,position
315                                 ',slot-name ',class .new-value. ,safep)))
316             (:boundp
317              `(instance-boundp ,pv-offset-form ,parameter ,position
318                                ',slot-name ',class)))))))
319
320 (define-walker-template pv-offset) ; These forms get munged by mutate slots.
321 (defmacro pv-offset (arg) arg)
322 (define-walker-template instance-accessor-parameter)
323 (defmacro instance-accessor-parameter (x) x)
324
325 ;;; It is safe for these two functions to be wrong. They just try to
326 ;;; guess what the most likely case will be.
327 (defun generate-fast-class-slot-access-p (class-form slot-name-form)
328   (let ((class (and (constantp class-form) (constant-form-value class-form)))
329         (slot-name (and (constantp slot-name-form)
330                         (constant-form-value slot-name-form))))
331     (and (eq **boot-state** 'complete)
332          (standard-class-p class)
333          (not (eq class *the-class-t*)) ; shouldn't happen, though.
334          (let ((slotd (find-slot-definition class slot-name)))
335            (and slotd (eq :class (slot-definition-allocation slotd)))))))
336
337 (defun constant-value-or-nil (form)
338   (and (constantp form) (constant-form-value form)))
339
340 (defun slot-access-strategy (class slot-name type &optional conservative)
341   ;; CONSERVATIVE means we should assume custom access pattern even if
342   ;; there are no custom accessors defined if the metaclass is non-standard.
343   ;;
344   ;; This is needed because DEFCLASS generates accessor methods before possible
345   ;; SLOT-VALUE-USING-CLASS methods are defined, which causes them to take
346   ;; the slow path unless we make the conservative assumption here.
347   (if (eq **boot-state** 'complete)
348       (let (slotd)
349         (cond ((or
350                 ;; Conditions, structures, and classes for which FIND-CLASS
351                 ;; doesn't return them yet.
352                 ;; FIXME: surely we can get faster accesses for structures?
353                 (not (standard-class-p class))
354                 ;; Should not happen... (FIXME: assert instead?)
355                 (eq class *the-class-t*)
356                 (not (class-finalized-p class))
357                 ;; Strangeness...
358                 (not (setf slotd (find-slot-definition class slot-name))))
359                :accessor)
360               ((and (slot-accessor-std-p slotd type)
361                     (or (not conservative) (eq *the-class-standard-class* (class-of class))))
362                ;; The best case.
363                :standard)
364               (t
365                :custom)))
366       :standard))
367
368 ;;;; SLOT-VALUE
369
370 (defmacro instance-read (pv-offset parameter position slot-name class)
371   (ecase (slot-access-strategy (constant-value-or-nil class)
372                                (constant-value-or-nil slot-name)
373                                'reader)
374     (:standard
375      `(instance-read-standard
376        .pv. ,(slot-vector-symbol position)
377        ,pv-offset (accessor-slot-value ,parameter ,slot-name)
378        ,(if (generate-fast-class-slot-access-p class slot-name)
379             :class :instance)))
380     (:custom
381      `(instance-read-custom .pv. ,pv-offset ,parameter))
382     (:accessor
383      `(accessor-slot-value ,parameter ,slot-name))))
384
385 (defmacro instance-read-standard (pv slots pv-offset default &optional kind)
386   (unless (member kind '(nil :instance :class))
387     (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind))
388   (let* ((index (gensym))
389          (value index))
390     `(locally (declare #.*optimize-speed*)
391        (let ((,index (svref ,pv ,pv-offset))
392              (,slots (truly-the simple-vector ,slots)))
393          (setq ,value (typecase ,index
394                         ;; FIXME: the line marked by KLUDGE below (and
395                         ;; the analogous spot in
396                         ;; INSTANCE-WRITE-STANDARD) is there purely to
397                         ;; suppress a type mismatch warning that
398                         ;; propagates through to user code.
399                         ;; Presumably SLOTS at this point can never
400                         ;; actually be NIL, but the compiler seems to
401                         ;; think it could, so we put this here to shut
402                         ;; it up.  (see also mail Rudi Schlatte
403                         ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30
404                         ,@(when (or (null kind) (eq kind :instance))
405                                 `((fixnum
406                                    (clos-slots-ref ,slots ,index))))
407                         ,@(when (or (null kind) (eq kind :class))
408                                 `((cons (cdr ,index))))
409                         (t
410                          +slot-unbound+)))
411          (if (eq ,value +slot-unbound+)
412              ,default
413              ,value)))))
414
415 (defmacro instance-read-custom (pv pv-offset parameter)
416   `(locally (declare #.*optimize-speed*)
417      (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter)))
418
419 ;;;; (SETF SLOT-VALUE)
420
421 (defmacro instance-write (pv-offset parameter position slot-name class new-value
422                           &optional check-type-p)
423   (ecase (slot-access-strategy (constant-value-or-nil class)
424                                (constant-value-or-nil slot-name)
425                                'writer)
426     (:standard
427      `(instance-write-standard
428        .pv. ,(slot-vector-symbol position)
429        ,pv-offset ,new-value
430        ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form
431        ;; is executed (if it is executed).
432        (accessor-set-slot-value ,parameter ,slot-name .good-new-value.)
433        ,(if (generate-fast-class-slot-access-p class slot-name)
434             :class :instance)
435        ,check-type-p))
436     (:custom
437      `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value))
438     (:accessor
439      (if check-type-p
440          ;; FIXME: We don't want this here. If it's _possible_ the fast path
441          ;; is applicable, we want to use it as well.
442          `(safe-set-slot-value ,parameter ,slot-name ,new-value)
443          `(accessor-set-slot-value ,parameter ,slot-name ,new-value)))))
444
445 (defmacro instance-write-standard (pv slots pv-offset new-value default
446                                    &optional kind safep)
447   (unless (member kind '(nil :instance :class))
448     (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind))
449   (let* ((index (gensym))
450          (new-value-form
451           (if safep
452               `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset)))))
453                  (declare (type (or function null) .typecheckfun.))
454                  (if .typecheckfun.
455                      (funcall .typecheckfun. ,new-value)
456                      ,new-value))
457               new-value)))
458     `(locally (declare #.*optimize-speed*)
459        (let ((.good-new-value. ,new-value-form)
460              (,index (svref ,pv ,pv-offset)))
461          (typecase ,index
462            ,@(when (or (null kind) (eq kind :instance))
463                    `((fixnum (and ,slots
464                                   (setf (clos-slots-ref ,slots ,index)
465                                         .good-new-value.)))))
466            ,@(when (or (null kind) (eq kind :class))
467                    `((cons (setf (cdr ,index) .good-new-value.))))
468            (t ,default))))))
469
470 (defmacro instance-write-custom (pv pv-offset parameter new-value)
471   `(locally (declare #.*optimize-speed*)
472      (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter)))
473
474 ;;;; SLOT-BOUNDP
475
476 (defmacro instance-boundp (pv-offset parameter position slot-name class)
477   (ecase (slot-access-strategy (constant-value-or-nil class)
478                                (constant-value-or-nil slot-name)
479                                'boundp)
480     (:standard
481      `(instance-boundp-standard
482        .pv. ,(slot-vector-symbol position)
483        ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
484        ,(if (generate-fast-class-slot-access-p class slot-name)
485             :class :instance)))
486     (:custom
487      `(instance-boundp-custom .pv. ,pv-offset ,parameter))
488     (:accessor
489      `(accessor-slot-boundp ,parameter ,slot-name))))
490
491 (defmacro instance-boundp-standard (pv slots pv-offset default
492                                     &optional kind)
493   (unless (member kind '(nil :instance :class))
494     (error "illegal kind argument to ~S: ~S" 'instance-boundp-standard kind))
495   (let* ((index (gensym)))
496     `(locally (declare #.*optimize-speed*)
497        (let ((,index (svref ,pv ,pv-offset)))
498          (typecase ,index
499            ,@(when (or (null kind) (eq kind :instance))
500                    `((fixnum (not (and ,slots
501                                        (eq (clos-slots-ref ,slots ,index)
502                                            +slot-unbound+))))))
503            ,@(when (or (null kind) (eq kind :class))
504                    `((cons (not (eq (cdr ,index) +slot-unbound+)))))
505            (t ,default))))))
506
507 (defmacro instance-boundp-custom (pv pv-offset parameter)
508   `(locally (declare #.*optimize-speed*)
509      (funcall (slot-info-boundp (svref ,pv (1+ ,pv-offset))) ,parameter)))
510
511 ;;; This magic function has quite a job to do indeed.
512 ;;;
513 ;;; The careful reader will recall that <slots> contains all of the
514 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
515 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
516 ;;;
517 ;;; At the time these calls were produced, the first argument was
518 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
519 ;;; convert those pv-offset arguments into the actual number that is
520 ;;; the correct offset into the pv.
521 ;;;
522 ;;; But first, oh but first, we sort <slots> a bit so that for each
523 ;;; argument we have the slots in alphabetical order. This
524 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
525 ;;; having fewer PV's floating around. Even if the gain is only
526 ;;; modest, it costs nothing.
527 (defun slot-name-lists-from-slots (slots)
528   (let ((slots (mutate-slots slots)))
529     (let* ((slot-name-lists
530             (mapcar (lambda (parameter-entry)
531                       (cons nil (mapcar #'car (cdr parameter-entry))))
532                     slots)))
533       (mapcar (lambda (r+snl)
534                 (when (or (car r+snl) (cdr r+snl))
535                   r+snl))
536               slot-name-lists))))
537
538 (defun mutate-slots (slots)
539   (let ((sorted-slots (sort-slots slots))
540         (pv-offset -1))
541     (dolist (parameter-entry sorted-slots)
542       (dolist (slot-entry (cdr parameter-entry))
543         (incf pv-offset)
544         (dolist (form (cdr slot-entry))
545           (setf (cadr form) pv-offset))
546         ;; Count one more for the slot we use for SLOT-INFO.
547         (incf pv-offset)))
548     sorted-slots))
549
550 (defun symbol-pkg-name (sym)
551   (let ((pkg (symbol-package sym)))
552     (if pkg (package-name pkg) "")))
553
554 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
555 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
556 ;;; stable. This ordering is only used in to
557 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
558 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
559 ;;; floating around", so it sounds as though the instability won't
560 ;;; actually lead to bugs, just small inefficiency. But still, it
561 ;;; would be better to reimplement this function as a comparison based
562 ;;; on SYMBOL-HASH:
563 ;;;   * stable comparison
564 ;;;   * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
565 ;;;   * faster code.
566 (defun symbol-lessp (a b)
567   (if (eq (symbol-package a)
568           (symbol-package b))
569       (string-lessp (symbol-name a)
570                     (symbol-name b))
571       (string-lessp (symbol-pkg-name a)
572                     (symbol-pkg-name b))))
573
574 (defun symbol-or-cons-lessp (a b)
575   (etypecase a
576     (symbol (etypecase b
577               (symbol (symbol-lessp a b))
578               (cons t)))
579     (cons   (etypecase b
580               (symbol nil)
581               (cons (if (eq (car a) (car b))
582                         (symbol-or-cons-lessp (cdr a) (cdr b))
583                         (symbol-or-cons-lessp (car a) (car b))))))))
584
585 (defun sort-slots (slots)
586   (mapcar (lambda (parameter-entry)
587             (cons (car parameter-entry)
588                   (sort (cdr parameter-entry)   ;slot entries
589                         #'symbol-or-cons-lessp
590                         :key #'car)))
591           slots))
592
593 \f
594 ;;;; This needs to work in terms of metatypes and also needs to work
595 ;;;; for automatically generated reader and writer functions.
596 ;;;; Automatically generated reader and writer functions use this
597 ;;;; stuff too.
598
599 (defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
600                       &body body)
601   (let (slot-vars pv-parameters)
602     (loop for slots in slot-name-lists
603           for required-parameter in required-parameters
604           for i from 0
605           do (when slots
606                (push required-parameter pv-parameters)
607                (push (slot-vector-symbol i) slot-vars)))
608     `(pv-binding1 (,pv-table-form
609                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
610        ,@body)))
611
612 (defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars)
613                        &body body)
614   `(pv-env (,pv-table-form ,pv-parameters)
615      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
616                      slot-vars pv-parameters))
617        (declare (ignorable ,@(mapcar #'identity slot-vars)))
618        ,@body)))
619
620 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
621 ;;; overridden.
622 (define-symbol-macro pv-env-environment overridden)
623
624 (defmacro pv-env (&environment env
625                   (pv-table-form pv-parameters)
626                   &rest forms)
627   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
628   ;; symbol-macrolet.
629   (if (eq (macroexpand 'pv-env-environment env) 'default)
630       `(locally (declare (simple-vector .pv.))
631          ,@forms)
632       `(let* ((.pv-table. ,pv-table-form)
633               (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)))
634         (declare ,(make-pv-type-declaration '.pv.))
635         ,@forms)))
636
637 (defun split-declarations (body args req-args cnm-p parameters-setqd)
638   (let ((inner-decls nil)
639         (outer-decls nil)
640         decl)
641     (loop
642       (when (null body)
643         (return nil))
644       (setq decl (car body))
645       (unless (and (consp decl) (eq (car decl) 'declare))
646         (return nil))
647       (dolist (form (cdr decl))
648         (when (consp form)
649           (let* ((name (car form)))
650             (cond ((eq '%class name)
651                    (push `(declare ,form) inner-decls))
652                   ((or (member name '(ignore ignorable special dynamic-extent type))
653                        (info :type :kind name))
654                    (let* ((inners nil)
655                           (outers nil)
656                           (tail (cdr form))
657                           (head (if (eq 'type name)
658                                     (list name (pop tail))
659                                     (list name))))
660                      (dolist (var tail)
661                        (if (member var args :test #'eq)
662                            ;; Quietly remove IGNORE declarations on
663                            ;; args when a next-method is involved, to
664                            ;; prevent compiler warnings about ignored
665                            ;; args being read.
666                            (unless (and (eq 'ignore name)
667                                         (member var req-args :test #'eq)
668                                         (or cnm-p (member var parameters-setqd)))
669                              (push var outers))
670                            (push var inners)))
671                      (when outers
672                        (push `(declare (,@head ,@outers)) outer-decls))
673                      (when inners
674                        (push `(declare (,@head ,@inners)) inner-decls))))
675                   (t
676                    ;; All other declarations are not variable declarations,
677                    ;; so they become outer declarations.
678                    (push `(declare ,form) outer-decls))))))
679       (setq body (cdr body)))
680     (values outer-decls inner-decls body)))
681
682 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
683 ;;; declaration (which is a naming style internal to PCL) into an
684 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
685 ;;; throughout SBCL, understood by the main compiler); or if there's
686 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
687 ;;; lambda expression.
688 (defun name-method-lambda (method-lambda)
689   (let ((method-name *method-name*))
690     (if method-name
691         `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda))
692         method-lambda)))
693
694 (defun make-method-initargs-form-internal (method-lambda initargs env)
695   (declare (ignore env))
696   (let (method-lambda-args
697         lmf ; becomes body of function
698         lmf-params)
699     (if (not (and (= 3 (length method-lambda))
700                   (= 2 (length (setq method-lambda-args (cadr method-lambda))))
701                   (consp (setq lmf (third method-lambda)))
702                   (eq 'simple-lexical-method-functions (car lmf))
703                   (eq (car method-lambda-args)
704                       (cadr (setq lmf-params (cadr lmf))))
705                   (eq (cadr method-lambda-args)
706                       (caddr lmf-params))))
707         `(list* :function ,(name-method-lambda method-lambda)
708                 ',initargs)
709         (let* ((lambda-list (car lmf-params))
710                (nreq 0)
711                (restp nil)
712                (args nil))
713           (dolist (arg lambda-list)
714             (when (member arg '(&optional &rest &key))
715               (setq restp t)
716               (return nil))
717             (when (eq arg '&aux)
718               (return nil))
719             (incf nreq)
720             (push arg args))
721           (setq args (nreverse args))
722           (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp))
723           (make-method-initargs-form-internal1
724            initargs (cddr lmf) args lmf-params restp)))))
725
726 (defun lambda-list-parameter-names (lambda-list)
727   ;; Given a valid lambda list, extract the parameter names.
728   (loop for x in lambda-list
729         with res = nil
730         do (unless (member x lambda-list-keywords :test #'eq)
731              (if (consp x)
732                  (let ((name (car x)))
733                    (if (consp name)
734                        ;; ... ((:BAR FOO) 1)
735                        (push (second name) res)
736                        ;; ... (FOO 1)
737                        (push name res))
738                    ;; ... (... 1 FOO-P)
739                    (let ((name-p (cddr x)))
740                      (when name-p
741                        (push (car name-p) res))))
742                  ;; ... FOO
743                  (push x res)))
744         finally (return res)))
745
746 (defun make-method-initargs-form-internal1
747     (initargs body req-args lmf-params restp)
748   (let* (;; The lambda-list of the method, minus specifiers
749          (lambda-list (car lmf-params))
750          ;; Names of the parameters that will be in the outermost lambda-list
751          ;; (and whose bound declarations thus need to be in OUTER-DECLS).
752          (outer-parameters req-args)
753          ;; The lambda-list used by BIND-ARGS
754          (bind-list lambda-list)
755          (parameters-setqd (getf (cdr lmf-params) :parameters-setqd))
756          (auxp (member '&aux bind-list))
757          (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
758     ;; Try to use the normal function call machinery instead of BIND-ARGS
759     ;; binding the arguments, unless:
760     (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
761                 ;; in any case.
762                 (and (not restp) (not auxp))
763                 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
764                 ;; list of all non-required arguments.
765                 call-next-method-p)
766       (setf ;; We don't want a binding for .REST-ARG.
767             restp nil
768             ;; Get all the parameters for declaration parsing
769             outer-parameters (lambda-list-parameter-names lambda-list)
770             ;; Ensure that BIND-ARGS won't do anything (since
771             ;; BIND-LIST won't contain any non-required parameters,
772             ;; and REQ-ARGS will be of an equal length). We still want
773             ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
774             ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
775             ;; of rebinding SETQd required arguments around the method
776             ;; body.
777             bind-list req-args))
778     (multiple-value-bind (outer-decls inner-decls body-sans-decls)
779         (split-declarations
780          body outer-parameters req-args call-next-method-p parameters-setqd)
781       (let* ((rest-arg (when restp
782                          '.rest-arg.))
783              (fmf-lambda-list (if rest-arg
784                                   (append req-args (list '&rest rest-arg))
785                                   (if call-next-method-p
786                                       req-args
787                                       lambda-list))))
788         `(list*
789           :function
790           (let* ((fmf (,(if *method-name* 'named-lambda 'lambda)
791                         ,@(when *method-name*
792                                 ;; function name
793                                 (list `(fast-method ,@*method-name*)))
794                         ;; The lambda-list of the FMF
795                         (.pv. .next-method-call. ,@fmf-lambda-list)
796                         ;; body of the function
797                         (declare (ignorable .pv. .next-method-call.)
798                                  (disable-package-locks pv-env-environment))
799                         ,@outer-decls
800                         (symbol-macrolet ((pv-env-environment default))
801                           (fast-lexical-method-functions
802                               (,bind-list .next-method-call. ,req-args ,rest-arg
803                                 ,@(cdddr lmf-params))
804                             ,@inner-decls
805                             ,@body-sans-decls))))
806                  (mf (%make-method-function fmf nil)))
807             (set-funcallable-instance-function
808              mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
809             mf)
810           ',initargs)))))
811
812 ;;; Use arrays and hash tables and the fngen stuff to make this much
813 ;;; better. It doesn't really matter, though, because a function
814 ;;; returned by this will get called only when the user explicitly
815 ;;; funcalls a result of method-function. BUT, this is needed to make
816 ;;; early methods work.
817 (defun method-function-from-fast-function (fmf plist)
818   (declare (type function fmf))
819   (let* ((method-function nil)
820          (snl (getf plist :slot-name-lists))
821          (pv-table (when snl
822                      (intern-pv-table :slot-name-lists snl)))
823          (arg-info (getf plist :arg-info))
824          (nreq (car arg-info))
825          (restp (cdr arg-info)))
826     (setq method-function
827           (lambda (method-args next-methods)
828             (let* ((pv (when pv-table
829                          (get-pv method-args pv-table)))
830                    (nm (car next-methods))
831                    (nms (cdr next-methods))
832                    (nmc (when nm
833                           (make-method-call
834                            :function (if (std-instance-p nm)
835                                          (method-function nm)
836                                          nm)
837                            :call-method-args (list nms)))))
838               (apply fmf pv nmc method-args))))
839     ;; FIXME: this looks dangerous.
840     (let* ((fname (%fun-name fmf)))
841       (when (and fname (eq (car fname) 'fast-method))
842         (set-fun-name method-function (cons 'slow-method (cdr fname)))))
843     method-function))
844
845 ;;; this is similar to the above, only not quite.  Only called when
846 ;;; the MOP is heavily involved.  Not quite parallel to
847 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
848 ;;; over the actual PV-CELL in this case.
849 (defun method-function-from-fast-method-call (fmc)
850   (let* ((fmf (fast-method-call-function fmc))
851          (pv (fast-method-call-pv fmc))
852          (arg-info (fast-method-call-arg-info fmc))
853          (nreq (car arg-info))
854          (restp (cdr arg-info)))
855     (lambda (method-args next-methods)
856       (let* ((nm (car next-methods))
857              (nms (cdr next-methods))
858              (nmc (when nm
859                     (make-method-call
860                      :function (if (std-instance-p nm)
861                                    (method-function nm)
862                                    nm)
863                      :call-method-args (list nms)))))
864         (apply fmf pv nmc method-args)))))
865
866 (defun get-pv (method-args pv-table)
867   (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
868     (when pv-wrappers
869       (pv-table-lookup pv-table pv-wrappers))))
870
871 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
872   (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
873
874 (defun pv-wrappers-from-pv-args (&rest args)
875   (loop for arg in args
876         collect (valid-wrapper-of arg)))
877
878 (defun pv-wrappers-from-all-args (pv-table args)
879   (loop for snl in (pv-table-slot-name-lists pv-table)
880         and arg in args
881         when snl
882         collect (valid-wrapper-of arg)))
883
884 ;;; Return the subset of WRAPPERS which is used in the cache
885 ;;; of PV-TABLE.
886 (defun pv-wrappers-from-all-wrappers (pv-table wrappers)
887   (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
888         when snl
889         collect w))