1 ;;;; permutation vectors
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
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
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.
40 (defmacro instance-slot-index
(wrapper slot-name
)
42 (declare (fixnum pos
))
44 (dolist (sn (wrapper-instance-slots-layout ,wrapper
))
45 (when (eq ,slot-name sn
) (return-from loop pos
))
48 (declaim (inline make-pv-table
))
49 (defstruct (pv-table (:predicate pv-tablep
)
51 (cache nil
:type
(or cache null
))
52 (pv-size 0 :type fixnum
)
53 (slot-name-lists nil
:type list
))
55 (defun make-pv-table-type-declaration (var)
56 `(type pv-table
,var
))
58 ;;; Used for interning parts of SLOT-NAME-LISTS, as part of
59 ;;; PV-TABLE interning -- just to save space.
60 (defvar *slot-name-lists
* (make-hash-table :test
'equal
))
62 ;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS
64 (defvar *pv-tables
* (make-hash-table :test
'equal
))
66 ;;; Indexes PV-TABLES by indivisual slot names used.
67 (defvar *pv-tables-by-slots
* (make-hash-table :test
'equal
))
69 ;;; ...and one lock to rule them. Spinlock because for certain (rare)
70 ;;; cases this lock might be grabbed in the course of method dispatch
71 ;;; -- and mostly this is already under the *big-compiler-lock*.
73 (sb-thread::make-spinlock
:name
"pv table index lock"))
75 (defun intern-pv-table (&key slot-name-lists
)
77 (flet ((intern-slot-names (slot-names)
78 (or (gethash slot-names
*slot-name-lists
*)
79 (setf (gethash slot-names
*slot-name-lists
*) slot-names
)))
80 (%intern-pv-table
(snl)
81 (or (gethash snl
*pv-tables
*)
82 (setf (gethash snl
*pv-tables
*)
85 (make-pv-table :slot-name-lists snl
))))))
86 (sb-thread::with-spinlock
(*pv-lock
*)
88 (%intern-pv-table
(mapcar #'intern-slot-names slot-name-lists
))))
91 (dolist (slot-name-list slot-name-lists
)
92 (dolist (slot-name (cdr slot-name-list
))
93 (pushnew pv-table
(gethash slot-name
*pv-tables-by-slots
*))
95 (setf (pv-table-pv-size pv-table
) pv-index
)))
98 (defun map-pv-table-references-of (slot-name function
)
99 (dolist (table (sb-thread::with-spinlock
(*pv-lock
*)
100 (gethash slot-name
*pv-tables-by-slots
*)))
101 (funcall function table
)))
103 (defun optimize-slot-value-by-class-p (class slot-name type
)
104 (or (not (eq *boot-state
* 'complete
))
105 (let ((slotd (find-slot-definition class slot-name
)))
107 (slot-accessor-std-p slotd type
)))))
109 (defun compute-pv-slot (slot-name wrapper class class-slots
)
110 (if (symbolp slot-name
)
111 (when (optimize-slot-value-by-class-p class slot-name
'all
)
112 (or (instance-slot-index wrapper slot-name
)
113 (assq slot-name class-slots
)))
114 (when (consp slot-name
)
115 (case (first slot-name
)
117 (when (eq *boot-state
* 'complete
)
118 (let ((gf (gdefinition (second slot-name
))))
119 (when (generic-function-p gf
)
120 (accessor-values1 gf
(first slot-name
) class
)))))
121 (t (bug "Don't know how to deal with ~S in ~S"
122 slot-name
'compute-pv-slots
))))))
124 (defun compute-pv (slot-name-lists wrappers
)
125 (unless (listp wrappers
)
126 (setq wrappers
(list wrappers
)))
128 (dolist (slot-names slot-name-lists
)
130 (let* ((wrapper (pop wrappers
))
131 (std-p (typep wrapper
'wrapper
))
132 (class (wrapper-class* wrapper
))
133 (class-slots (and std-p
(wrapper-class-slots wrapper
))))
134 (dolist (slot-name (cdr slot-names
))
136 (compute-pv-slot slot-name wrapper class class-slots
)
139 (let* ((n (length elements
))
141 (loop for i from
(1- n
) downto
0
142 do
(setf (svref pv i
) (pop elements
)))
145 (defun pv-table-lookup (pv-table pv-wrappers
)
146 (let* ((slot-name-lists (pv-table-slot-name-lists pv-table
))
147 (cache (or (pv-table-cache pv-table
)
148 (setf (pv-table-cache pv-table
)
149 (make-cache :key-count
(- (length slot-name-lists
)
150 (count nil slot-name-lists
))
153 (multiple-value-bind (hitp value
) (probe-cache cache pv-wrappers
)
156 (let* ((pv (compute-pv slot-name-lists pv-wrappers
))
157 (new-cache (fill-cache cache pv-wrappers pv
)))
158 ;; This is safe: if another thread races us here the loser just
159 ;; misses the next time as well.
160 (unless (eq new-cache cache
)
161 (setf (pv-table-cache pv-table
) new-cache
))
164 (defun make-pv-type-declaration (var)
165 `(type simple-vector
,var
))
167 (defvar *pv-table-cache-update-info
* nil
)
169 (defun update-pv-table-cache-info (class)
170 (let ((slot-names-for-pv-table-update nil
)
172 (dolist (icu *pv-table-cache-update-info
*)
173 (if (eq (car icu
) class
)
174 (pushnew (cdr icu
) slot-names-for-pv-table-update
)
175 (push icu new-icui
)))
176 (setq *pv-table-cache-update-info
* new-icui
)
177 (when slot-names-for-pv-table-update
178 (update-all-pv-table-caches class slot-names-for-pv-table-update
))))
180 (defun update-all-pv-table-caches (class slot-names
)
181 (let* ((cwrapper (class-wrapper class
))
182 (std-p (typep cwrapper
'wrapper
))
183 (class-slots (and std-p
(wrapper-class-slots cwrapper
)))
189 (compute-pv-slot slot-name cwrapper class class-slots
)
193 (dolist (slot-name slot-names
)
194 (map-pv-table-references-of
197 (pushnew pv-table pv-tables
))))
198 (dolist (pv-table pv-tables
)
199 (let* ((cache (pv-table-cache pv-table
))
200 (slot-name-lists (pv-table-slot-name-lists pv-table
))
201 (pv-size (pv-table-pv-size pv-table
))
202 (pv-map (make-array pv-size
:initial-element nil
)))
203 (let ((map-index 0) (param-index 0))
204 (dolist (slot-name-list slot-name-lists
)
205 (dolist (slot-name (cdr slot-name-list
))
206 (let ((a (assoc slot-name new-values
)))
207 (setf (svref pv-map map-index
)
208 (and a
(cons param-index
(cdr a
)))))
212 (map-cache (lambda (wrappers pv
)
213 (update-slots-in-pv wrappers pv
214 cwrapper pv-size pv-map
))
217 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map
)
219 (when (eq cwrapper wrappers
)
220 (dotimes-fixnum (i pv-size
)
221 (let ((map (svref pv-map i
)))
223 (aver (= (car map
) 0))
224 (setf (svref pv i
) (cdr map
))))))
225 (when (memq cwrapper wrappers
)
227 (dolist (wrapper wrappers
)
228 (when (eq wrapper cwrapper
)
229 (dotimes-fixnum (i pv-size
)
230 (let ((map (svref pv-map i
)))
231 (when (and map
(= (car map
) param
))
232 (setf (svref pv i
) (cdr map
))))))
235 (defun can-optimize-access (form required-parameters env
)
236 (destructuring-bind (op var-form slot-name-form
&optional new-value
) form
237 (let ((type (ecase op
239 (set-slot-value 'writer
)
240 (slot-boundp 'boundp
)))
241 (var (extract-the var-form
))
242 (slot-name (constant-form-value slot-name-form env
)))
244 (let* ((rebound?
(caddr (var-declaration '%variable-rebinding var env
)))
245 (parameter-or-nil (car (memq (or rebound? var
)
246 required-parameters
))))
247 (when parameter-or-nil
248 (let* ((class-name (caddr (var-declaration '%class
251 (class (find-class class-name nil
)))
252 (when (or (not (eq *boot-state
* 'complete
))
253 (and class
(not (class-finalized-p class
))))
255 (when (and class-name
(not (eq class-name t
)))
256 (when (or (null type
)
258 (memq *the-class-structure-object
*
259 (class-precedence-list class
))))
260 (optimize-slot-value-by-class-p class slot-name type
))
261 (values (cons parameter-or-nil
(or class class-name
))
265 ;;; Check whether the binding of the named variable is modified in the
267 (defun parameter-modified-p (parameter-name env
)
268 (let ((modified-variables (macroexpand '%parameter-binding-modified env
)))
269 (memq parameter-name modified-variables
)))
271 (defun optimize-slot-value (form slots required-parameters env
)
272 (multiple-value-bind (sparameter slot-name
)
273 (can-optimize-access form required-parameters env
)
275 (let ((optimized-form
276 (optimize-instance-access slots
:read sparameter
278 ;; We don't return the optimized form directly, since there's
279 ;; still a chance that we'll find out later on that the
280 ;; optimization should not have been done, for example due to
281 ;; the walker encountering a SETQ on SPARAMETER later on in
282 ;; the body [ see for example clos.impure.lisp test with :name
283 ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
284 ;; the decision until the compiler macroexpands
285 ;; OPTIMIZED-SLOT-VALUE.
287 ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
288 ;; this point (instead of when expanding
289 ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
290 ;; SLOTS. If that mutation isn't done during the walking,
291 ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
292 ;; form around the body, and compilation will fail. -- JES,
294 `(optimized-slot-value ,form
,(car sparameter
) ,optimized-form
))
295 `(accessor-slot-value ,@(cdr form
)))))
297 (defmacro optimized-slot-value
(form parameter-name optimized-form
299 ;; Either use OPTIMIZED-FORM or fall back to the safe
300 ;; ACCESSOR-SLOT-VALUE.
301 (if (parameter-modified-p parameter-name env
)
302 `(accessor-slot-value ,@(cdr form
))
305 (defun optimize-set-slot-value (form slots required-parameters env
)
306 (multiple-value-bind (sparameter slot-name new-value
)
307 (can-optimize-access form required-parameters env
)
309 (let ((optimized-form
310 (optimize-instance-access slots
:write sparameter
311 slot-name new-value
)))
312 ;; See OPTIMIZE-SLOT-VALUE
313 `(optimized-set-slot-value ,form
,(car sparameter
) ,optimized-form
))
314 `(accessor-set-slot-value ,@(cdr form
)))))
316 (defmacro optimized-set-slot-value
(form parameter-name optimized-form
318 (cond ((safe-code-p env
)
319 ;; Don't optimize slot value setting in safe code, since the
320 ;; optimized version will fail to catch some type errors
321 ;; (for example when a subclass declares a tighter type for
322 ;; the slot than a superclass).
323 `(safe-set-slot-value ,@(cdr form
)))
324 ((parameter-modified-p parameter-name env
)
325 `(accessor-set-slot-value ,@(cdr form
)))
329 (defun optimize-slot-boundp (form slots required-parameters env
)
330 (multiple-value-bind (sparameter slot-name
)
331 (can-optimize-access form required-parameters env
)
333 (let ((optimized-form
334 (optimize-instance-access slots
:boundp sparameter
336 ;; See OPTIMIZE-SLOT-VALUE
337 `(optimized-slot-boundp ,form
,(car sparameter
) ,optimized-form
))
338 `(accessor-slot-boundp ,@(cdr form
)))))
340 (defmacro optimized-slot-boundp
(form parameter-name optimized-form
342 (if (parameter-modified-p parameter-name env
)
343 `(accessor-slot-boundp ,@(cdr form
))
346 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
347 ;;; of a required parameter to the function. The alist is in order, so
348 ;;; the position of an entry in the alist corresponds to the
349 ;;; argument's position in the lambda list.
350 (defun optimize-instance-access (slots
355 (let ((class (if (consp sparameter
) (cdr sparameter
) *the-class-t
*))
356 (parameter (if (consp sparameter
) (car sparameter
) sparameter
)))
357 (if (and (eq *boot-state
* 'complete
)
359 (memq *the-class-structure-object
* (class-precedence-list class
)))
360 (let ((slotd (find-slot-definition class slot-name
)))
363 `(,(slot-definition-defstruct-accessor-symbol slotd
) ,parameter
))
365 `(setf (,(slot-definition-defstruct-accessor-symbol slotd
)
370 (let* ((parameter-entry (assq parameter slots
))
371 (slot-entry (assq slot-name
(cdr parameter-entry
)))
372 (position (posq parameter-entry slots
))
373 (pv-offset-form (list 'pv-offset
''.PV-OFFSET.
)))
374 (unless parameter-entry
375 (bug "slot optimization bewilderment: O-I-A"))
377 (setq slot-entry
(list slot-name
))
378 (push slot-entry
(cdr parameter-entry
)))
379 (push pv-offset-form
(cdr slot-entry
))
382 `(instance-read ,pv-offset-form
,parameter
,position
383 ',slot-name
',class
))
385 `(let ((.new-value.
,new-value
))
386 (instance-write ,pv-offset-form
,parameter
,position
387 ',slot-name
',class .new-value.
)))
389 `(instance-boundp ,pv-offset-form
,parameter
,position
390 ',slot-name
',class
)))))))
392 (define-walker-template pv-offset
) ; These forms get munged by mutate slots.
393 (defmacro pv-offset
(arg) arg
)
394 (define-walker-template instance-accessor-parameter
)
395 (defmacro instance-accessor-parameter
(x) x
)
397 ;;; It is safe for these two functions to be wrong. They just try to
398 ;;; guess what the most likely case will be.
399 (defun generate-fast-class-slot-access-p (class-form slot-name-form
)
400 (let ((class (and (constantp class-form
) (constant-form-value class-form
)))
401 (slot-name (and (constantp slot-name-form
)
402 (constant-form-value slot-name-form
))))
403 (and (eq *boot-state
* 'complete
)
404 (standard-class-p class
)
405 (not (eq class
*the-class-t
*)) ; shouldn't happen, though.
406 (let ((slotd (find-slot-definition class slot-name
)))
407 (and slotd
(eq :class
(slot-definition-allocation slotd
)))))))
409 (defun skip-fast-slot-access-p (class-form slot-name-form type
)
410 (let ((class (and (constantp class-form
) (constant-form-value class-form
)))
411 (slot-name (and (constantp slot-name-form
)
412 (constant-form-value slot-name-form
))))
413 (and (eq *boot-state
* 'complete
)
414 (standard-class-p class
)
415 (not (eq class
*the-class-t
*)) ; shouldn't happen, though.
416 ;; FIXME: Is this really right? "Don't skip if there is
417 ;; no slot definition."
418 (let ((slotd (find-slot-definition class slot-name
)))
420 (not (slot-accessor-std-p slotd type
)))))))
422 (defmacro instance-read-internal
(pv slots pv-offset default
&optional kind
)
423 (unless (member kind
'(nil :instance
:class
:default
))
424 (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind
))
425 (if (eq kind
:default
)
427 (let* ((index (gensym))
429 `(locally (declare #.
*optimize-speed
*)
430 (let ((,index
(svref ,pv
,pv-offset
)))
431 (setq ,value
(typecase ,index
432 ;; FIXME: the line marked by KLUDGE below
433 ;; (and the analogous spot in
434 ;; INSTANCE-WRITE-INTERNAL) is there purely
435 ;; to suppress a type mismatch warning that
436 ;; propagates through to user code.
437 ;; Presumably SLOTS at this point can never
438 ;; actually be NIL, but the compiler seems
439 ;; to think it could, so we put this here
440 ;; to shut it up. (see also mail Rudi
441 ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
443 ,@(when (or (null kind
) (eq kind
:instance
))
446 (clos-slots-ref ,slots
,index
)))))
447 ,@(when (or (null kind
) (eq kind
:class
))
448 `((cons (cdr ,index
))))
450 (if (eq ,value
+slot-unbound
+)
454 (defmacro instance-read
(pv-offset parameter position slot-name class
)
455 (if (skip-fast-slot-access-p class slot-name
'reader
)
456 `(accessor-slot-value ,parameter
,slot-name
)
457 `(instance-read-internal .pv.
,(slot-vector-symbol position
)
458 ,pv-offset
(accessor-slot-value ,parameter
,slot-name
)
459 ,(if (generate-fast-class-slot-access-p class slot-name
)
462 (defmacro instance-write-internal
(pv slots pv-offset new-value default
464 (unless (member kind
'(nil :instance
:class
:default
))
465 (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind
))
466 (if (eq kind
:default
)
468 (let* ((index (gensym)))
469 `(locally (declare #.
*optimize-speed
*)
470 (let ((,index
(svref ,pv
,pv-offset
)))
472 ,@(when (or (null kind
) (eq kind
:instance
))
473 `((fixnum (and ,slots
474 (setf (clos-slots-ref ,slots
,index
)
476 ,@(when (or (null kind
) (eq kind
:class
))
477 `((cons (setf (cdr ,index
) ,new-value
))))
480 (defmacro instance-write
(pv-offset
486 (if (skip-fast-slot-access-p class slot-name
'writer
)
487 `(accessor-set-slot-value ,parameter
,slot-name
,new-value
)
488 `(instance-write-internal .pv.
,(slot-vector-symbol position
)
489 ,pv-offset
,new-value
490 (accessor-set-slot-value ,parameter
,slot-name
,new-value
)
491 ,(if (generate-fast-class-slot-access-p class slot-name
)
494 (defmacro instance-boundp-internal
(pv slots pv-offset default
496 (unless (member kind
'(nil :instance
:class
:default
))
497 (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind
))
498 (if (eq kind
:default
)
500 (let* ((index (gensym)))
501 `(locally (declare #.
*optimize-speed
*)
502 (let ((,index
(svref ,pv
,pv-offset
)))
504 ,@(when (or (null kind
) (eq kind
:instance
))
505 `((fixnum (not (and ,slots
506 (eq (clos-slots-ref ,slots
,index
)
508 ,@(when (or (null kind
) (eq kind
:class
))
509 `((cons (not (eq (cdr ,index
) +slot-unbound
+)))))
512 (defmacro instance-boundp
(pv-offset parameter position slot-name class
)
513 (if (skip-fast-slot-access-p class slot-name
'boundp
)
514 `(accessor-slot-boundp ,parameter
,slot-name
)
515 `(instance-boundp-internal .pv.
,(slot-vector-symbol position
)
516 ,pv-offset
(accessor-slot-boundp ,parameter
,slot-name
)
517 ,(if (generate-fast-class-slot-access-p class slot-name
)
520 ;;; This magic function has quite a job to do indeed.
522 ;;; The careful reader will recall that <slots> contains all of the
523 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
524 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
526 ;;; At the time these calls were produced, the first argument was
527 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
528 ;;; convert those pv-offset arguments into the actual number that is
529 ;;; the correct offset into the pv.
531 ;;; But first, oh but first, we sort <slots> a bit so that for each
532 ;;; argument we have the slots in alphabetical order. This
533 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
534 ;;; having fewer PV's floating around. Even if the gain is only
535 ;;; modest, it costs nothing.
536 (defun slot-name-lists-from-slots (slots)
537 (let ((slots (mutate-slots slots
)))
538 (let* ((slot-name-lists
539 (mapcar (lambda (parameter-entry)
540 (cons nil
(mapcar #'car
(cdr parameter-entry
))))
542 (mapcar (lambda (r+snl
)
543 (when (or (car r
+snl
) (cdr r
+snl
))
547 (defun mutate-slots (slots)
548 (let ((sorted-slots (sort-slots slots
))
550 (dolist (parameter-entry sorted-slots
)
551 (dolist (slot-entry (cdr parameter-entry
))
553 (dolist (form (cdr slot-entry
))
554 (setf (cadr form
) pv-offset
))))
557 (defun symbol-pkg-name (sym)
558 (let ((pkg (symbol-package sym
)))
559 (if pkg
(package-name pkg
) "")))
561 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
562 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
563 ;;; stable. This ordering is only used in to
564 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
565 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
566 ;;; floating around", so it sounds as though the instability won't
567 ;;; actually lead to bugs, just small inefficiency. But still, it
568 ;;; would be better to reimplement this function as a comparison based
570 ;;; * stable comparison
571 ;;; * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
573 (defun symbol-lessp (a b
)
574 (if (eq (symbol-package a
)
576 (string-lessp (symbol-name a
)
578 (string-lessp (symbol-pkg-name a
)
579 (symbol-pkg-name b
))))
581 (defun symbol-or-cons-lessp (a b
)
584 (symbol (symbol-lessp a b
))
588 (cons (if (eq (car a
) (car b
))
589 (symbol-or-cons-lessp (cdr a
) (cdr b
))
590 (symbol-or-cons-lessp (car a
) (car b
))))))))
592 (defun sort-slots (slots)
593 (mapcar (lambda (parameter-entry)
594 (cons (car parameter-entry
)
595 (sort (cdr parameter-entry
) ;slot entries
596 #'symbol-or-cons-lessp
601 ;;;; This needs to work in terms of metatypes and also needs to work
602 ;;;; for automatically generated reader and writer functions.
603 ;;;; Automatically generated reader and writer functions use this
606 (defmacro pv-binding
((required-parameters slot-name-lists pv-table-form
)
608 (let (slot-vars pv-parameters
)
609 (loop for slots in slot-name-lists
610 for required-parameter in required-parameters
613 (push required-parameter pv-parameters
)
614 (push (slot-vector-symbol i
) slot-vars
)))
615 `(pv-binding1 (,pv-table-form
616 ,(nreverse pv-parameters
) ,(nreverse slot-vars
))
619 (defmacro pv-binding1
((pv-table-form pv-parameters slot-vars
)
621 `(pv-env (,pv-table-form
,pv-parameters
)
622 (let (,@(mapcar (lambda (slot-var p
) `(,slot-var
(get-slots-or-nil ,p
)))
623 slot-vars pv-parameters
))
624 (declare (ignorable ,@(mapcar #'identity slot-vars
)))
627 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
629 (define-symbol-macro pv-env-environment overridden
)
631 (defmacro pv-env
(&environment env
632 (pv-table-form pv-parameters
)
634 ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
636 (if (eq (macroexpand 'pv-env-environment env
) 'default
)
638 `(let* ((.pv-table.
,pv-table-form
)
639 (.pv.
(pv-table-lookup-pv-args .pv-table.
,@pv-parameters
)))
640 (declare ,(make-pv-type-declaration '.pv.
))
643 (defvar *non-var-declarations
*
644 ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
645 ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
646 ;; SBCL doesn't have 'em, VALUES should probably be removed from
657 (defvar *var-declarations-with-arg
*
661 (defvar *var-declarations-without-arg
*
663 ignorable special dynamic-extent
664 ;; FIXME: Possibly this entire list and variable could go away.
665 ;; If not, certainly we should remove all these built-in typenames
666 ;; from the list, and replace them with a test for "is it a type
667 ;; name?" (CLTL1 allowed only built-in type names as declarations,
668 ;; but ANSI CL allows any type name as a declaration.)
669 array atom base-char bignum bit bit-vector character compiled-function
670 complex cons double-float extended-char
671 fixnum float function hash-table integer
672 keyword list long-float nil null number package pathname random-state ratio
673 rational readtable sequence short-float signed-byte simple-array
674 simple-bit-vector simple-string simple-vector single-float standard-char
675 stream string symbol t unsigned-byte vector
))
677 (defun split-declarations (body args maybe-reads-params-p
)
678 (let ((inner-decls nil
)
681 (loop (when (null body
) (return nil
))
682 (setq decl
(car body
))
683 (unless (and (consp decl
)
684 (eq (car decl
) 'declare
))
686 (dolist (form (cdr decl
))
688 (let ((declaration-name (car form
)))
689 (if (member declaration-name
*non-var-declarations
*)
690 (push `(declare ,form
) outer-decls
)
692 (member declaration-name
693 *var-declarations-with-arg
*))
695 (member declaration-name
696 *var-declarations-without-arg
*))
697 (dname (list (pop form
)))
698 (inners nil
) (outers nil
))
699 (unless (or arg-p non-arg-p
)
700 ;; FIXME: This warning, and perhaps the
701 ;; various *VAR-DECLARATIONS-FOO* and/or
702 ;; *NON-VAR-DECLARATIONS* variables,
703 ;; could probably go away now that we're not
704 ;; trying to be portable between different
705 ;; CLTL1 hosts the way PCL was. (Note that to
706 ;; do this right, we need to be able to handle
707 ;; user-defined (DECLAIM (DECLARATION FOO))
709 (warn "The declaration ~S is not understood by ~S.~@
710 Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
711 (Assuming it is a variable declaration without argument)."
712 declaration-name
'split-declarations
714 '*non-var-declarations
*
715 '*var-declarations-with-arg
*
716 '*var-declarations-without-arg
*)
717 (push declaration-name
*var-declarations-without-arg
*))
719 (setq dname
(append dname
(list (pop form
)))))
721 (%class
(push `(declare (,@dname
,@form
)) inner-decls
))
724 (if (member var args
)
725 ;; Quietly remove IGNORE declarations
726 ;; on args when a next-method is
727 ;; involved, to prevent compiler
728 ;; warnings about ignored args being
730 (unless (and maybe-reads-params-p
731 (eq (car dname
) 'ignore
))
735 (push `(declare (,@dname
,@outers
)) outer-decls
))
738 `(declare (,@dname
,@inners
))
740 (setq body
(cdr body
)))
741 (values outer-decls inner-decls body
)))
743 ;;; Pull a name out of the %METHOD-NAME declaration in the function
744 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
745 (defun body-method-name (body)
746 (multiple-value-bind (real-body declarations documentation
)
748 (declare (ignore real-body documentation
))
749 (let ((name-decl (get-declaration '%method-name declarations
)))
751 (destructuring-bind (name) name-decl
754 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
755 ;;; declaration (which is a naming style internal to PCL) into an
756 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
757 ;;; throughout SBCL, understood by the main compiler); or if there's
758 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
759 ;;; lambda expression.
760 (defun name-method-lambda (method-lambda)
761 (let ((method-name (body-method-name (cddr method-lambda
))))
763 `(named-lambda (slow-method ,method-name
) ,(rest method-lambda
))
766 (defun make-method-initargs-form-internal (method-lambda initargs env
)
767 (declare (ignore env
))
768 (let (method-lambda-args
769 lmf
; becomes body of function
771 (if (not (and (= 3 (length method-lambda
))
772 (= 2 (length (setq method-lambda-args
(cadr method-lambda
))))
773 (consp (setq lmf
(third method-lambda
)))
774 (eq 'simple-lexical-method-functions
(car lmf
))
775 (eq (car method-lambda-args
)
776 (cadr (setq lmf-params
(cadr lmf
))))
777 (eq (cadr method-lambda-args
)
778 (caddr lmf-params
))))
779 `(list* :function
,(name-method-lambda method-lambda
)
781 (let* ((lambda-list (car lmf-params
))
785 (dolist (arg lambda-list
)
786 (when (member arg
'(&optional
&rest
&key
))
793 (setq args
(nreverse args
))
794 (setf (getf (getf initargs
'plist
) :arg-info
) (cons nreq restp
))
795 (make-method-initargs-form-internal1
796 initargs
(cddr lmf
) args lmf-params restp
)))))
798 (defun lambda-list-parameter-names (lambda-list)
799 ;; Given a valid lambda list, extract the parameter names.
800 (loop for x in lambda-list
802 do
(unless (member x lambda-list-keywords
)
804 (let ((name (car x
)))
806 ;; ... ((:BAR FOO) 1)
807 (push (second name
) res
)
811 (let ((name-p (cddr x
)))
813 (push (car name-p
) res
))))
816 finally
(return res
)))
818 (defun make-method-initargs-form-internal1
819 (initargs body req-args lmf-params restp
)
820 (let* (;; The lambda-list of the method, minus specifiers
821 (lambda-list (car lmf-params
))
822 ;; Names of the parameters that will be in the outermost lambda-list
823 ;; (and whose bound declarations thus need to be in OUTER-DECLS).
824 (outer-parameters req-args
)
825 ;; The lambda-list used by BIND-ARGS
826 (bind-list lambda-list
)
827 (setq-p (getf (cdr lmf-params
) :setq-p
))
828 (auxp (member '&aux bind-list
))
829 (call-next-method-p (getf (cdr lmf-params
) :call-next-method-p
)))
830 ;; Try to use the normal function call machinery instead of BIND-ARGS
831 ;; binding the arguments, unless:
832 (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
834 (and (not restp
) (not auxp
))
835 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
836 ;; list of all non-required arguments.
838 (setf ;; We don't want a binding for .REST-ARG.
840 ;; Get all the parameters for declaration parsing
841 outer-parameters
(lambda-list-parameter-names lambda-list
)
842 ;; Ensure that BIND-ARGS won't do anything (since
843 ;; BIND-LIST won't contain any non-required parameters,
844 ;; and REQ-ARGS will be of an equal length). We still want
845 ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
846 ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
847 ;; of rebinding SETQd required arguments around the method
850 (multiple-value-bind (outer-decls inner-decls body-sans-decls
)
852 body outer-parameters
(or call-next-method-p setq-p
))
853 (let* ((rest-arg (when restp
855 (fmf-lambda-list (if rest-arg
856 (append req-args
(list '&rest rest-arg
))
857 (if call-next-method-p
862 (let* ((fmf (,(if (body-method-name body
) 'named-lambda
'lambda
)
863 ,@(when (body-method-name body
)
865 (list (cons 'fast-method
(body-method-name body
))))
866 ;; The lambda-list of the FMF
867 (.pv. .next-method-call.
,@fmf-lambda-list
)
868 ;; body of the function
869 (declare (ignorable .pv. .next-method-call.
)
870 (disable-package-locks pv-env-environment
))
872 (symbol-macrolet ((pv-env-environment default
))
873 (fast-lexical-method-functions
874 (,bind-list .next-method-call.
,req-args
,rest-arg
875 ,@(cdddr lmf-params
))
877 ,@body-sans-decls
))))
878 (mf (%make-method-function fmf nil
)))
879 (set-funcallable-instance-function
880 mf
(method-function-from-fast-function fmf
',(getf initargs
'plist
)))
884 ;;; Use arrays and hash tables and the fngen stuff to make this much
885 ;;; better. It doesn't really matter, though, because a function
886 ;;; returned by this will get called only when the user explicitly
887 ;;; funcalls a result of method-function. BUT, this is needed to make
888 ;;; early methods work.
889 (defun method-function-from-fast-function (fmf plist
)
890 (declare (type function fmf
))
891 (let* ((method-function nil
)
892 (snl (getf plist
:slot-name-lists
))
894 (intern-pv-table :slot-name-lists snl
)))
895 (arg-info (getf plist
:arg-info
))
896 (nreq (car arg-info
))
897 (restp (cdr arg-info
)))
898 (setq method-function
899 (lambda (method-args next-methods
)
900 (let* ((pv (when pv-table
901 (get-pv method-args pv-table
)))
902 (nm (car next-methods
))
903 (nms (cdr next-methods
))
906 :function
(if (std-instance-p nm
)
909 :call-method-args
(list nms
)))))
910 (apply fmf pv nmc method-args
))))
911 ;; FIXME: this looks dangerous.
912 (let* ((fname (%fun-name fmf
)))
913 (when (and fname
(eq (car fname
) 'fast-method
))
914 (set-fun-name method-function
(cons 'slow-method
(cdr fname
)))))
917 ;;; this is similar to the above, only not quite. Only called when
918 ;;; the MOP is heavily involved. Not quite parallel to
919 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
920 ;;; over the actual PV-CELL in this case.
921 (defun method-function-from-fast-method-call (fmc)
922 (let* ((fmf (fast-method-call-function fmc
))
923 (pv (fast-method-call-pv fmc
))
924 (arg-info (fast-method-call-arg-info fmc
))
925 (nreq (car arg-info
))
926 (restp (cdr arg-info
)))
927 (lambda (method-args next-methods
)
928 (let* ((nm (car next-methods
))
929 (nms (cdr next-methods
))
932 :function
(if (std-instance-p nm
)
935 :call-method-args
(list nms
)))))
936 (apply fmf pv nmc method-args
)))))
938 (defun get-pv (method-args pv-table
)
939 (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args
)))
941 (pv-table-lookup pv-table pv-wrappers
))))
943 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters
)
944 (pv-table-lookup pv-table
(pv-wrappers-from-pv-args pv-parameters
)))
946 (defun pv-wrappers-from-pv-args (&rest args
)
948 (dolist (arg args
(if (cdr wrappers
) (nreverse wrappers
) (car wrappers
)))
949 (let ((wrapper (wrapper-of arg
)))
950 (push (if (invalid-wrapper-p wrapper
)
951 (check-wrapper-validity wrapper
)
955 (defun pv-wrappers-from-all-args (pv-table args
)
956 (loop for snl in
(pv-table-slot-name-lists pv-table
) and arg in args
958 collect
(wrapper-of arg
) into wrappers
959 finally
(return (if (cdr wrappers
) wrappers
(car wrappers
)))))
961 ;;; Return the subset of WRAPPERS which is used in the cache
963 (defun pv-wrappers-from-all-wrappers (pv-table wrappers
)
964 (loop for snl in
(pv-table-slot-name-lists pv-table
) and w in wrappers
966 collect w into result
967 finally
(return (if (cdr result
) result
(car result
)))))