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