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 (defmacro instance-slot-index
(wrapper slot-name
)
30 (declare (fixnum pos
))
32 (dolist (sn (wrapper-instance-slots-layout ,wrapper
))
33 (when (eq ,slot-name sn
) (return-from loop pos
))
36 (defun pv-cache-limit-fn (nlines)
37 (default-limit-fn nlines
))
39 (defstruct (pv-table (:predicate pv-tablep
)
40 (:constructor make-pv-table-internal
41 (slot-name-lists call-list
))
43 (cache nil
:type
(or cache null
))
44 (pv-size 0 :type fixnum
)
45 (slot-name-lists nil
:type list
)
46 (call-list nil
:type list
))
48 #-sb-fluid
(declaim (sb-ext:freeze-type pv-table
))
50 ;;; FIXME: The comment below seem to indicate that this was intended
51 ;;; to be actually used, however, it isn't anymore, and was commented
52 ;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that
53 ;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18
55 ;;; help new slot-value-using-class methods affect fast iv access
57 ;;; (defvar *all-pv-table-list* nil)
59 (declaim (inline make-pv-table
))
60 (defun make-pv-table (&key slot-name-lists call-list
)
61 (make-pv-table-internal slot-name-lists call-list
))
63 (defun make-pv-table-type-declaration (var)
64 `(type pv-table
,var
))
66 (defvar *slot-name-lists-inner
* (make-hash-table :test
'equal
))
67 (defvar *slot-name-lists-outer
* (make-hash-table :test
'equal
))
69 ;;; Entries in this are lists of (table . pv-offset-list).
70 (defvar *pv-key-to-pv-table-table
* (make-hash-table :test
'equal
))
72 (defun intern-pv-table (&key slot-name-lists call-list
)
75 (or (gethash x
*slot-name-lists-inner
*)
76 (setf (gethash x
*slot-name-lists-inner
*) (copy-list x
))))
78 (or (gethash x
*slot-name-lists-outer
*)
79 (setf (gethash x
*slot-name-lists-outer
*)
80 (let ((snl (copy-list (cdr x
)))
83 (make-pv-table :slot-name-lists snl
86 (outer (mapcar #'inner
(cons call-list slot-name-lists
)))))
89 (dolist (slot-name-list slot-name-lists
)
90 (dolist (slot-name (cdr slot-name-list
))
91 (note-pv-table-reference slot-name pv-index pv-table
)
93 (dolist (gf-call call-list
)
94 (note-pv-table-reference gf-call pv-index pv-table
)
96 (setf (pv-table-pv-size pv-table
) pv-index
)))
99 (defun note-pv-table-reference (ref pv-offset pv-table
)
100 (let ((entry (gethash ref
*pv-key-to-pv-table-table
*)))
102 (let ((table-entry (assq pv-table entry
)))
103 (when (and (null table-entry
)
104 (> (length entry
) 8))
105 (let ((new-table-table (make-hash-table :size
16 :test
'eq
)))
106 (dolist (table-entry entry
)
107 (setf (gethash (car table-entry
) new-table-table
)
109 (setf (gethash ref
*pv-key-to-pv-table-table
*) new-table-table
)))
111 (if (null table-entry
)
112 (let ((new (cons pv-table pv-offset
)))
114 (push new
(cdr entry
))
115 (setf (gethash ref
*pv-key-to-pv-table-table
*)
117 (push pv-offset
(cdr table-entry
)))
118 (return-from note-pv-table-reference nil
))))
119 (let ((list (gethash pv-table entry
)))
121 (push pv-offset
(cdr list
))
122 (setf (gethash pv-table entry
) (list pv-offset
)))))
125 (defun map-pv-table-references-of (ref function
)
126 (let ((entry (gethash ref
*pv-key-to-pv-table-table
*)))
128 (dolist (table+pv-offset-list entry
)
130 (car table
+pv-offset-list
)
131 (cdr table
+pv-offset-list
)))
132 (maphash function entry
)))
135 (defun optimize-slot-value-by-class-p (class slot-name type
)
136 (or (not (eq *boot-state
* 'complete
))
137 (let ((slotd (find-slot-definition class slot-name
)))
139 (slot-accessor-std-p slotd type
)))))
141 (defun compute-pv-slot (slot-name wrapper class class-slots
)
142 (if (symbolp slot-name
)
143 (when (optimize-slot-value-by-class-p class slot-name
'all
)
144 (or (instance-slot-index wrapper slot-name
)
145 (assq slot-name class-slots
)))
146 (when (consp slot-name
)
147 (case (first slot-name
)
149 (when (eq *boot-state
* 'complete
)
150 (let ((gf (gdefinition (second slot-name
))))
151 (when (generic-function-p gf
)
152 (accessor-values1 gf
(first slot-name
) class
)))))
153 (t (bug "Don't know how to deal with ~S in ~S"
154 slot-name
'compute-pv-slots
))))))
156 (defun compute-pv (slot-name-lists wrappers
)
157 (unless (listp wrappers
)
158 (setq wrappers
(list wrappers
)))
160 (dolist (slot-names slot-name-lists
161 (make-permutation-vector (nreverse elements
)))
163 (let* ((wrapper (pop wrappers
))
164 (std-p (typep wrapper
'wrapper
))
165 (class (wrapper-class* wrapper
))
166 (class-slots (and std-p
(wrapper-class-slots wrapper
))))
167 (dolist (slot-name (cdr slot-names
))
169 (compute-pv-slot slot-name wrapper class class-slots
)
173 (defun compute-calls (call-list wrappers
)
174 (declare (ignore call-list wrappers
))
178 (compute-emf-from-wrappers call wrappers
))
183 #||
; Need to finish this, then write the maintenance functions.
184 (defun compute-emf-from-wrappers (call wrappers
)
186 (destructuring-bind (gf-name nreq restp arg-info
) call
187 (if (eq gf-name
'make-instance
)
188 (error "should not get here") ; there is another mechanism for this.
190 (if (not (eq *boot-state
* 'complete
))
191 (apply (gdefinition gf-name
) args
)
192 (let* ((gf (gdefinition gf-name
))
193 (arg-info (arg-info-reader gf
))
196 (emf (cache-miss-values-internal gf arg-info
197 wrappers classes types
199 (update-all-pv-tables call wrappers emf
)
200 (invoke-emf emf args
))))))))
203 (defun make-permutation-vector (indexes)
204 (make-array (length indexes
) :initial-contents indexes
))
206 (defun pv-table-lookup (pv-table pv-wrappers
)
207 (let* ((slot-name-lists (pv-table-slot-name-lists pv-table
))
208 (call-list (pv-table-call-list pv-table
))
209 (cache (or (pv-table-cache pv-table
)
210 (setf (pv-table-cache pv-table
)
211 (get-cache (- (length slot-name-lists
)
212 (count nil slot-name-lists
))
216 (or (probe-cache cache pv-wrappers
)
217 (let* ((pv (compute-pv slot-name-lists pv-wrappers
))
218 (calls (compute-calls call-list pv-wrappers
))
219 (pv-cell (cons pv calls
))
220 (new-cache (fill-cache cache pv-wrappers pv-cell
)))
221 (unless (eq new-cache cache
)
222 (setf (pv-table-cache pv-table
) new-cache
))
225 (defun make-pv-type-declaration (var)
226 `(type simple-vector
,var
))
228 (defmacro pvref
(pv index
)
231 (defmacro copy-pv
(pv)
234 (defun make-calls-type-declaration (var)
235 `(type simple-vector
,var
))
237 (defmacro callsref
(calls index
)
238 `(svref ,calls
,index
))
240 (defvar *pv-table-cache-update-info
* nil
)
242 (defun update-pv-table-cache-info (class)
243 (let ((slot-names-for-pv-table-update nil
)
245 (dolist (icu *pv-table-cache-update-info
*)
246 (if (eq (car icu
) class
)
247 (pushnew (cdr icu
) slot-names-for-pv-table-update
)
248 (push icu new-icui
)))
249 (setq *pv-table-cache-update-info
* new-icui
)
250 (when slot-names-for-pv-table-update
251 (update-all-pv-table-caches class slot-names-for-pv-table-update
))))
253 (defun update-all-pv-table-caches (class slot-names
)
254 (let* ((cwrapper (class-wrapper class
))
255 (std-p (typep cwrapper
'wrapper
))
256 (class-slots (and std-p
(wrapper-class-slots cwrapper
)))
262 (compute-pv-slot slot-name cwrapper class class-slots
)
266 (dolist (slot-name slot-names
)
267 (map-pv-table-references-of
269 (lambda (pv-table pv-offset-list
)
270 (declare (ignore pv-offset-list
))
271 (pushnew pv-table pv-tables
))))
272 (dolist (pv-table pv-tables
)
273 (let* ((cache (pv-table-cache pv-table
))
274 (slot-name-lists (pv-table-slot-name-lists pv-table
))
275 (pv-size (pv-table-pv-size pv-table
))
276 (pv-map (make-array pv-size
:initial-element nil
)))
277 (let ((map-index 0) (param-index 0))
278 (dolist (slot-name-list slot-name-lists
)
279 (dolist (slot-name (cdr slot-name-list
))
280 (let ((a (assoc slot-name new-values
)))
281 (setf (svref pv-map map-index
)
282 (and a
(cons param-index
(cdr a
)))))
286 (map-cache (lambda (wrappers pv-cell
)
287 (update-slots-in-pv wrappers
(car pv-cell
)
288 cwrapper pv-size pv-map
))
291 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map
)
293 (when (eq cwrapper wrappers
)
294 (dotimes-fixnum (i pv-size
)
295 (let ((map (svref pv-map i
)))
297 (aver (= (car map
) 0))
298 (setf (pvref pv i
) (cdr map
))))))
299 (when (memq cwrapper wrappers
)
301 (dolist (wrapper wrappers
)
302 (when (eq wrapper cwrapper
)
303 (dotimes-fixnum (i pv-size
)
304 (let ((map (svref pv-map i
)))
305 (when (and map
(= (car map
) param
))
306 (setf (pvref pv i
) (cdr map
))))))
309 (defun can-optimize-access (form required-parameters env
)
310 (let ((type (ecase (car form
)
312 (set-slot-value 'writer
)
313 (slot-boundp 'boundp
)))
315 (slot-name (eval (caddr form
)))) ; known to be constant
316 (can-optimize-access1 var required-parameters env type slot-name
)))
318 ;;; FIXME: This looks like an internal helper function for
319 ;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
320 ;;; bare from several places in the code. Perhaps the two functions
321 ;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
322 ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
323 ;;; args instead of optional ones, too.
324 (defun can-optimize-access1 (var required-parameters env
325 &optional type slot-name
)
326 (when (and (consp var
) (eq 'the
(car var
)))
327 ;; FIXME: We should assert list of length 3 here. Or maybe we
328 ;; should just define EXTRACT-THE, replace the whole
331 ;; (AWHEN (EXTRACT-THE VAR)
333 ;; and then use EXTRACT-THE similarly to clean up the other tests
334 ;; against 'THE scattered through the PCL code.
335 (setq var
(caddr var
)))
337 (let* ((rebound?
(caddr (var-declaration '%variable-rebinding var env
)))
338 (parameter-or-nil (car (memq (or rebound? var
)
339 required-parameters
))))
340 (when parameter-or-nil
341 (let* ((class-name (caddr (var-declaration '%class
344 (class (find-class class-name nil
)))
345 (when (or (not (eq *boot-state
* 'complete
))
346 (and class
(not (class-finalized-p class
))))
348 (when (and class-name
(not (eq class-name t
)))
349 (when (or (null type
)
351 (memq *the-class-structure-object
*
352 (class-precedence-list class
))))
353 (optimize-slot-value-by-class-p class slot-name type
))
354 (cons parameter-or-nil
(or class class-name
)))))))))
356 ;;; Check whether the binding of the named variable is modified in the
358 (defun parameter-modified-p (parameter-name env
)
359 (let ((modified-variables (macroexpand '%parameter-binding-modified env
)))
360 (memq parameter-name modified-variables
)))
362 (defun optimize-slot-value (slots sparameter form
)
364 (let ((optimized-form
365 (destructuring-bind (ignore1 ignore2 slot-name-form
) form
366 (declare (ignore ignore1 ignore2
))
367 (let ((slot-name (eval slot-name-form
)))
368 (optimize-instance-access slots
:read sparameter
370 ;; We don't return the optimized form directly, since there's
371 ;; still a chance that we'll find out later on that the
372 ;; optimization should not have been done, for example due to
373 ;; the walker encountering a SETQ on SPARAMETER later on in
374 ;; the body [ see for example clos.impure.lisp test with :name
375 ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
376 ;; the decision until the compiler macroexpands
377 ;; OPTIMIZED-SLOT-VALUE.
379 ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
380 ;; this point (instead of when expanding
381 ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
382 ;; SLOTS. If that mutation isn't done during the walking,
383 ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
384 ;; form around the body, and compilation will fail. -- JES,
386 `(optimized-slot-value ,form
,(car sparameter
) ,optimized-form
))
387 `(accessor-slot-value ,@(cdr form
))))
389 (defmacro optimized-slot-value
(form parameter-name optimized-form
391 ;; Either use OPTIMIZED-FORM or fall back to the safe
392 ;; ACCESSOR-SLOT-VALUE.
393 (if (parameter-modified-p parameter-name env
)
394 `(accessor-slot-value ,@(cdr form
))
397 (defun optimize-set-slot-value (slots sparameter form
)
399 (let ((optimized-form
400 (destructuring-bind (ignore1 ignore2 slot-name-form new-value
) form
401 (declare (ignore ignore1 ignore2
))
402 (let ((slot-name (eval slot-name-form
)))
403 (optimize-instance-access slots
408 ;; See OPTIMIZE-SLOT-VALUE
409 `(optimized-set-slot-value ,form
,(car sparameter
) ,optimized-form
))
410 `(accessor-set-slot-value ,@(cdr form
))))
412 (defmacro optimized-set-slot-value
(form parameter-name optimized-form
414 (cond ((safe-code-p env
)
415 ;; Don't optimize slot value setting in safe code, since the
416 ;; optimized version will fail to catch some type errors
417 ;; (for example when a subclass declares a tighter type for
418 ;; the slot than a superclass).
419 `(safe-set-slot-value ,@(cdr form
)))
420 ((parameter-modified-p parameter-name env
)
421 `(accessor-set-slot-value ,@(cdr form
)))
425 (defun optimize-slot-boundp (slots sparameter form
)
427 (let ((optimized-form
429 ;; FIXME: In CMU CL ca. 19991205, this binding list
430 ;; had a fourth element in it, NEW-VALUE. It's hard
431 ;; to see how that could possibly be right, since
432 ;; SLOT-BOUNDP has no NEW-VALUE. Since it was
433 ;; causing a failure in building PCL for SBCL, so I
434 ;; changed it to match the definition of
435 ;; SLOT-BOUNDP (and also to match the list used in
436 ;; the similar OPTIMIZE-SLOT-VALUE,
437 ;; above). However, I'm weirded out by this, since
438 ;; this is old code which has worked for ages to
439 ;; build PCL for CMU CL, so it's hard to see why it
440 ;; should need a patch like this in order to build
441 ;; PCL for SBCL. I'd like to return to this and
442 ;; find a test case which exercises this function
443 ;; both in CMU CL, to see whether it's really a
444 ;; previously-unexercised bug or whether I've
445 ;; misunderstood something (and, presumably,
446 ;; patched it wrong).
447 (slot-boundp-symbol instance slot-name-form
)
449 (declare (ignore slot-boundp-symbol instance
))
450 (let ((slot-name (eval slot-name-form
)))
451 (optimize-instance-access slots
456 ;; See OPTIMIZE-SLOT-VALUE
457 `(optimized-slot-boundp ,form
,(car sparameter
) ,optimized-form
))
458 `(accessor-slot-boundp ,@(cdr form
))))
460 (defmacro optimized-slot-boundp
(form parameter-name optimized-form
462 (if (parameter-modified-p parameter-name env
)
463 `(accessor-slot-boundp ,@(cdr form
))
466 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
467 ;;; of a required parameter to the function. The alist is in order, so
468 ;;; the position of an entry in the alist corresponds to the
469 ;;; argument's position in the lambda list.
470 (defun optimize-instance-access (slots
475 (let ((class (if (consp sparameter
) (cdr sparameter
) *the-class-t
*))
476 (parameter (if (consp sparameter
) (car sparameter
) sparameter
)))
477 (if (and (eq *boot-state
* 'complete
)
479 (memq *the-class-structure-object
* (class-precedence-list class
)))
480 (let ((slotd (find-slot-definition class slot-name
)))
483 `(,(slot-definition-defstruct-accessor-symbol slotd
) ,parameter
))
485 `(setf (,(slot-definition-defstruct-accessor-symbol slotd
)
490 (let* ((parameter-entry (assq parameter slots
))
491 (slot-entry (assq slot-name
(cdr parameter-entry
)))
492 (position (posq parameter-entry slots
))
493 (pv-offset-form (list 'pv-offset
''.PV-OFFSET.
)))
494 (unless parameter-entry
495 (bug "slot optimization bewilderment: O-I-A"))
497 (setq slot-entry
(list slot-name
))
498 (push slot-entry
(cdr parameter-entry
)))
499 (push pv-offset-form
(cdr slot-entry
))
502 `(instance-read ,pv-offset-form
,parameter
,position
503 ',slot-name
',class
))
505 `(let ((.new-value.
,new-value
))
506 (instance-write ,pv-offset-form
,parameter
,position
507 ',slot-name
',class .new-value.
)))
509 `(instance-boundp ,pv-offset-form
,parameter
,position
510 ',slot-name
',class
)))))))
512 (define-walker-template pv-offset
) ; These forms get munged by mutate slots.
513 (defmacro pv-offset
(arg) arg
)
514 (define-walker-template instance-accessor-parameter
)
515 (defmacro instance-accessor-parameter
(x) x
)
517 ;;; It is safe for these two functions to be wrong. They just try to
518 ;;; guess what the most likely case will be.
519 (defun generate-fast-class-slot-access-p (class-form slot-name-form
)
520 (let ((class (and (constantp class-form
) (constant-form-value class-form
)))
521 (slot-name (and (constantp slot-name-form
)
522 (constant-form-value slot-name-form
))))
523 (and (eq *boot-state
* 'complete
)
524 (standard-class-p class
)
525 (not (eq class
*the-class-t
*)) ; shouldn't happen, though.
526 (let ((slotd (find-slot-definition class slot-name
)))
527 (and slotd
(eq :class
(slot-definition-allocation slotd
)))))))
529 (defun skip-fast-slot-access-p (class-form slot-name-form type
)
530 (let ((class (and (constantp class-form
) (constant-form-value class-form
)))
531 (slot-name (and (constantp slot-name-form
)
532 (constant-form-value slot-name-form
))))
533 (and (eq *boot-state
* 'complete
)
534 (standard-class-p class
)
535 (not (eq class
*the-class-t
*)) ; shouldn't happen, though.
536 (let ((slotd (find-slot-definition class slot-name
)))
537 (and slotd
(skip-optimize-slot-value-by-class-p class
541 (defun skip-optimize-slot-value-by-class-p (class slot-name type
)
542 (let ((slotd (find-slot-definition class slot-name
)))
544 (eq *boot-state
* 'complete
)
545 (not (slot-accessor-std-p slotd type
)))))
547 (defmacro instance-read-internal
(pv slots pv-offset default
&optional kind
)
548 (unless (member kind
'(nil :instance
:class
:default
))
549 (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind
))
550 (if (eq kind
:default
)
552 (let* ((index (gensym))
554 `(locally (declare #.
*optimize-speed
*)
555 (let ((,index
(pvref ,pv
,pv-offset
)))
556 (setq ,value
(typecase ,index
557 ;; FIXME: the line marked by KLUDGE below
558 ;; (and the analogous spot in
559 ;; INSTANCE-WRITE-INTERNAL) is there purely
560 ;; to suppress a type mismatch warning that
561 ;; propagates through to user code.
562 ;; Presumably SLOTS at this point can never
563 ;; actually be NIL, but the compiler seems
564 ;; to think it could, so we put this here
565 ;; to shut it up. (see also mail Rudi
566 ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
568 ,@(when (or (null kind
) (eq kind
:instance
))
571 (clos-slots-ref ,slots
,index
)))))
572 ,@(when (or (null kind
) (eq kind
:class
))
573 `((cons (cdr ,index
))))
575 (if (eq ,value
+slot-unbound
+)
579 (defmacro instance-read
(pv-offset parameter position slot-name class
)
580 (if (skip-fast-slot-access-p class slot-name
'reader
)
581 `(accessor-slot-value ,parameter
,slot-name
)
582 `(instance-read-internal .pv.
,(slot-vector-symbol position
)
583 ,pv-offset
(accessor-slot-value ,parameter
,slot-name
)
584 ,(if (generate-fast-class-slot-access-p class slot-name
)
587 (defmacro instance-write-internal
(pv slots pv-offset new-value default
589 (unless (member kind
'(nil :instance
:class
:default
))
590 (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind
))
591 (if (eq kind
:default
)
593 (let* ((index (gensym)))
594 `(locally (declare #.
*optimize-speed
*)
595 (let ((,index
(pvref ,pv
,pv-offset
)))
597 ,@(when (or (null kind
) (eq kind
:instance
))
598 `((fixnum (and ,slots
599 (setf (clos-slots-ref ,slots
,index
)
601 ,@(when (or (null kind
) (eq kind
:class
))
602 `((cons (setf (cdr ,index
) ,new-value
))))
605 (defmacro instance-write
(pv-offset
611 (if (skip-fast-slot-access-p class slot-name
'writer
)
612 `(accessor-set-slot-value ,parameter
,slot-name
,new-value
)
613 `(instance-write-internal .pv.
,(slot-vector-symbol position
)
614 ,pv-offset
,new-value
615 (accessor-set-slot-value ,parameter
,slot-name
,new-value
)
616 ,(if (generate-fast-class-slot-access-p class slot-name
)
619 (defmacro instance-boundp-internal
(pv slots pv-offset default
621 (unless (member kind
'(nil :instance
:class
:default
))
622 (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind
))
623 (if (eq kind
:default
)
625 (let* ((index (gensym)))
626 `(locally (declare #.
*optimize-speed
*)
627 (let ((,index
(pvref ,pv
,pv-offset
)))
629 ,@(when (or (null kind
) (eq kind
:instance
))
630 `((fixnum (not (and ,slots
631 (eq (clos-slots-ref ,slots
,index
)
633 ,@(when (or (null kind
) (eq kind
:class
))
634 `((cons (not (eq (cdr ,index
) +slot-unbound
+)))))
637 (defmacro instance-boundp
(pv-offset parameter position slot-name class
)
638 (if (skip-fast-slot-access-p class slot-name
'boundp
)
639 `(accessor-slot-boundp ,parameter
,slot-name
)
640 `(instance-boundp-internal .pv.
,(slot-vector-symbol position
)
641 ,pv-offset
(accessor-slot-boundp ,parameter
,slot-name
)
642 ,(if (generate-fast-class-slot-access-p class slot-name
)
645 ;;; This magic function has quite a job to do indeed.
647 ;;; The careful reader will recall that <slots> contains all of the
648 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
649 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
651 ;;; At the time these calls were produced, the first argument was
652 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
653 ;;; convert those pv-offset arguments into the actual number that is
654 ;;; the correct offset into the pv.
656 ;;; But first, oh but first, we sort <slots> a bit so that for each
657 ;;; argument we have the slots in alphabetical order. This
658 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
659 ;;; having fewer PV's floating around. Even if the gain is only
660 ;;; modest, it costs nothing.
661 (defun slot-name-lists-from-slots (slots calls
)
662 (multiple-value-bind (slots calls
) (mutate-slots-and-calls slots calls
)
663 (let* ((slot-name-lists
664 (mapcar (lambda (parameter-entry)
665 (cons nil
(mapcar #'car
(cdr parameter-entry
))))
668 (mapcar #'car calls
)))
669 (dolist (call call-list
)
670 (dolist (arg (cdr call
))
672 (setf (car (nth arg slot-name-lists
)) t
))))
673 (setq slot-name-lists
(mapcar (lambda (r+snl
)
674 (when (or (car r
+snl
) (cdr r
+snl
))
677 (let ((cvt (apply #'vector
679 (mapcar (lambda (r+snl
)
680 (when r
+snl
(incf i
)))
682 (setq call-list
(mapcar (lambda (call)
684 (mapcar (lambda (arg)
690 (values slot-name-lists call-list
))))
692 (defun mutate-slots-and-calls (slots calls
)
693 (let ((sorted-slots (sort-slots slots
))
694 (sorted-calls (sort-calls (cdr calls
)))
696 (dolist (parameter-entry sorted-slots
)
697 (dolist (slot-entry (cdr parameter-entry
))
699 (dolist (form (cdr slot-entry
))
700 (setf (cadr form
) pv-offset
))))
701 (dolist (call-entry sorted-calls
)
703 (dolist (form (cdr call-entry
))
704 (setf (cadr form
) pv-offset
)))
705 (values sorted-slots sorted-calls
)))
707 (defun symbol-pkg-name (sym)
708 (let ((pkg (symbol-package sym
)))
709 (if pkg
(package-name pkg
) "")))
711 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
712 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
713 ;;; stable. This ordering is only used in to
714 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
715 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
716 ;;; floating around", so it sounds as though the instability won't
717 ;;; actually lead to bugs, just small inefficiency. But still, it
718 ;;; would be better to reimplement this function as a comparison based
720 ;;; * stable comparison
721 ;;; * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
723 (defun symbol-lessp (a b
)
724 (if (eq (symbol-package a
)
726 (string-lessp (symbol-name a
)
728 (string-lessp (symbol-pkg-name a
)
729 (symbol-pkg-name b
))))
731 (defun symbol-or-cons-lessp (a b
)
734 (symbol (symbol-lessp a b
))
738 (cons (if (eq (car a
) (car b
))
739 (symbol-or-cons-lessp (cdr a
) (cdr b
))
740 (symbol-or-cons-lessp (car a
) (car b
))))))))
742 (defun sort-slots (slots)
743 (mapcar (lambda (parameter-entry)
744 (cons (car parameter-entry
)
745 (sort (cdr parameter-entry
) ;slot entries
746 #'symbol-or-cons-lessp
750 (defun sort-calls (calls)
751 (sort calls
#'symbol-or-cons-lessp
:key
#'car
))
753 ;;;; This needs to work in terms of metatypes and also needs to work
754 ;;;; for automatically generated reader and writer functions.
755 ;;;; Automatically generated reader and writer functions use this
758 (defmacro pv-binding
((required-parameters slot-name-lists pv-table-form
)
760 (let (slot-vars pv-parameters
)
761 (loop for slots in slot-name-lists
762 for required-parameter in required-parameters
765 (push required-parameter pv-parameters
)
766 (push (slot-vector-symbol i
) slot-vars
)))
767 `(pv-binding1 (.pv. .calls.
,pv-table-form
768 ,(nreverse pv-parameters
) ,(nreverse slot-vars
))
771 (defmacro pv-binding1
((pv calls pv-table-form pv-parameters slot-vars
)
773 `(pv-env (,pv
,calls
,pv-table-form
,pv-parameters
)
774 (let (,@(mapcar (lambda (slot-var p
) `(,slot-var
(get-slots-or-nil ,p
)))
775 slot-vars pv-parameters
))
776 (declare (ignorable ,@(mapcar #'identity slot-vars
)))
779 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
781 (define-symbol-macro pv-env-environment overridden
)
783 (defmacro pv-env
(&environment env
784 (pv calls pv-table-form pv-parameters
)
786 ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
788 (if (eq (macroexpand 'pv-env-environment env
) 'default
)
789 `(let ((,pv
(car .pv-cell.
))
790 (,calls
(cdr .pv-cell.
)))
791 (declare ,(make-pv-type-declaration pv
)
792 ,(make-calls-type-declaration calls
))
795 `(let* ((.pv-table.
,pv-table-form
)
796 (.pv-cell.
(pv-table-lookup-pv-args .pv-table.
,@pv-parameters
))
797 (,pv
(car .pv-cell.
))
798 (,calls
(cdr .pv-cell.
)))
799 (declare ,(make-pv-type-declaration pv
))
800 (declare ,(make-calls-type-declaration calls
))
804 (defvar *non-var-declarations
*
805 ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
806 ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
807 ;; SBCL doesn't have 'em, VALUES should probably be removed from
818 (defvar *var-declarations-with-arg
*
822 (defvar *var-declarations-without-arg
*
824 ignorable special dynamic-extent
825 ;; FIXME: Possibly this entire list and variable could go away.
826 ;; If not, certainly we should remove all these built-in typenames
827 ;; from the list, and replace them with a test for "is it a type
828 ;; name?" (CLTL1 allowed only built-in type names as declarations,
829 ;; but ANSI CL allows any type name as a declaration.)
830 array atom base-char bignum bit bit-vector character compiled-function
831 complex cons double-float extended-char
832 fixnum float function hash-table integer
833 keyword list long-float nil null number package pathname random-state ratio
834 rational readtable sequence short-float signed-byte simple-array
835 simple-bit-vector simple-string simple-vector single-float standard-char
836 stream string symbol t unsigned-byte vector
))
838 (defun split-declarations (body args maybe-reads-params-p
)
839 (let ((inner-decls nil
)
842 (loop (when (null body
) (return nil
))
843 (setq decl
(car body
))
844 (unless (and (consp decl
)
845 (eq (car decl
) 'declare
))
847 (dolist (form (cdr decl
))
849 (let ((declaration-name (car form
)))
850 (if (member declaration-name
*non-var-declarations
*)
851 (push `(declare ,form
) outer-decls
)
853 (member declaration-name
854 *var-declarations-with-arg
*))
856 (member declaration-name
857 *var-declarations-without-arg
*))
858 (dname (list (pop form
)))
859 (inners nil
) (outers nil
))
860 (unless (or arg-p non-arg-p
)
861 ;; FIXME: This warning, and perhaps the
862 ;; various *VAR-DECLARATIONS-FOO* and/or
863 ;; *NON-VAR-DECLARATIONS* variables,
864 ;; could probably go away now that we're not
865 ;; trying to be portable between different
866 ;; CLTL1 hosts the way PCL was. (Note that to
867 ;; do this right, we need to be able to handle
868 ;; user-defined (DECLAIM (DECLARATION FOO))
870 (warn "The declaration ~S is not understood by ~S.~@
871 Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
872 (Assuming it is a variable declaration without argument)."
873 declaration-name
'split-declarations
875 '*non-var-declarations
*
876 '*var-declarations-with-arg
*
877 '*var-declarations-without-arg
*)
878 (push declaration-name
*var-declarations-without-arg
*))
880 (setq dname
(append dname
(list (pop form
)))))
882 (%class
(push `(declare (,@dname
,@form
)) inner-decls
))
885 (if (member var args
)
886 ;; Quietly remove IGNORE declarations
887 ;; on args when a next-method is
888 ;; involved, to prevent compiler
889 ;; warnings about ignored args being
891 (unless (and maybe-reads-params-p
892 (eq (car dname
) 'ignore
))
896 (push `(declare (,@dname
,@outers
)) outer-decls
))
899 `(declare (,@dname
,@inners
))
901 (setq body
(cdr body
)))
902 (values outer-decls inner-decls body
)))
904 ;;; Pull a name out of the %METHOD-NAME declaration in the function
905 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
906 (defun body-method-name (body)
907 (multiple-value-bind (real-body declarations documentation
)
909 (declare (ignore real-body documentation
))
910 (let ((name-decl (get-declaration '%method-name declarations
)))
912 (destructuring-bind (name) name-decl
915 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
916 ;;; declaration (which is a naming style internal to PCL) into an
917 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
918 ;;; throughout SBCL, understood by the main compiler); or if there's
919 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
920 ;;; lambda expression.
921 (defun name-method-lambda (method-lambda)
922 (let ((method-name (body-method-name (cddr method-lambda
))))
924 `(named-lambda (slow-method ,method-name
) ,(rest method-lambda
))
927 (defun make-method-initargs-form-internal (method-lambda initargs env
)
928 (declare (ignore env
))
929 (let (method-lambda-args
930 lmf
; becomes body of function
932 (if (not (and (= 3 (length method-lambda
))
933 (= 2 (length (setq method-lambda-args
(cadr method-lambda
))))
934 (consp (setq lmf
(third method-lambda
)))
935 (eq 'simple-lexical-method-functions
(car lmf
))
936 (eq (car method-lambda-args
)
937 (cadr (setq lmf-params
(cadr lmf
))))
938 (eq (cadr method-lambda-args
)
939 (caddr lmf-params
))))
940 `(list* :function
,(name-method-lambda method-lambda
)
942 (let* ((lambda-list (car lmf-params
))
946 (dolist (arg lambda-list
)
947 (when (member arg
'(&optional
&rest
&key
))
954 (setq args
(nreverse args
))
955 (setf (getf (getf initargs
'plist
) :arg-info
) (cons nreq restp
))
956 (make-method-initargs-form-internal1
957 initargs
(cddr lmf
) args lmf-params restp
)))))
959 (defun lambda-list-parameter-names (lambda-list)
960 ;; Given a valid lambda list, extract the parameter names.
961 (loop for x in lambda-list
963 do
(unless (member x lambda-list-keywords
)
965 (let ((name (car x
)))
967 ;; ... ((:BAR FOO) 1)
968 (push (second name
) res
)
972 (let ((name-p (cddr x
)))
974 (push (car name-p
) res
))))
977 finally
(return res
)))
979 (defun make-method-initargs-form-internal1
980 (initargs body req-args lmf-params restp
)
981 (let* (;; The lambda-list of the method, minus specifiers
982 (lambda-list (car lmf-params
))
983 ;; Names of the parameters that will be in the outermost lambda-list
984 ;; (and whose bound declarations thus need to be in OUTER-DECLS).
985 (outer-parameters req-args
)
986 ;; The lambda-list used by BIND-ARGS
987 (bind-list lambda-list
)
988 (setq-p (getf (cdr lmf-params
) :setq-p
))
989 (auxp (member '&aux bind-list
))
990 (call-next-method-p (getf (cdr lmf-params
) :call-next-method-p
)))
991 ;; Try to use the normal function call machinery instead of BIND-ARGS
992 ;; binding the arguments, unless:
993 (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
995 (and (not restp
) (not auxp
))
996 ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
997 ;; list of all non-required arguments.
999 (setf ;; We don't want a binding for .REST-ARG.
1001 ;; Get all the parameters for declaration parsing
1002 outer-parameters
(lambda-list-parameter-names lambda-list
)
1003 ;; Ensure that BIND-ARGS won't do anything (since
1004 ;; BIND-LIST won't contain any non-required parameters,
1005 ;; and REQ-ARGS will be of an equal length). We still want
1006 ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
1007 ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
1008 ;; of rebinding SETQd required arguments around the method
1010 bind-list req-args
))
1011 (multiple-value-bind (outer-decls inner-decls body-sans-decls
)
1013 body outer-parameters
(or call-next-method-p setq-p
))
1014 (let* ((rest-arg (when restp
1016 (fmf-lambda-list (if rest-arg
1017 (append req-args
(list '&rest rest-arg
))
1018 (if call-next-method-p
1023 (let* ((fmf (,(if (body-method-name body
) 'named-lambda
'lambda
)
1024 ,@(when (body-method-name body
)
1026 (list (cons 'fast-method
(body-method-name body
))))
1027 ;; The lambda-list of the FMF
1028 (.pv-cell. .next-method-call.
,@fmf-lambda-list
)
1029 ;; body of the function
1030 (declare (ignorable .pv-cell. .next-method-call.
)
1031 (disable-package-locks pv-env-environment
))
1033 (symbol-macrolet ((pv-env-environment default
))
1034 (fast-lexical-method-functions
1035 (,bind-list .next-method-call.
,req-args
,rest-arg
1036 ,@(cdddr lmf-params
))
1038 ,@body-sans-decls
))))
1039 (mf (%make-method-function fmf nil
)))
1040 (set-funcallable-instance-function
1041 mf
(method-function-from-fast-function fmf
',(getf initargs
'plist
)))
1045 ;;; Use arrays and hash tables and the fngen stuff to make this much
1046 ;;; better. It doesn't really matter, though, because a function
1047 ;;; returned by this will get called only when the user explicitly
1048 ;;; funcalls a result of method-function. BUT, this is needed to make
1049 ;;; early methods work.
1050 (defun method-function-from-fast-function (fmf plist
)
1051 (declare (type function fmf
))
1052 (let* ((method-function nil
)
1053 (calls (getf plist
:call-list
))
1054 (snl (getf plist
:slot-name-lists
))
1055 (pv-table (when (or calls snl
)
1056 (intern-pv-table :call-list calls
:slot-name-lists snl
)))
1057 (arg-info (getf plist
:arg-info
))
1058 (nreq (car arg-info
))
1059 (restp (cdr arg-info
)))
1060 (setq method-function
1061 (lambda (method-args next-methods
)
1062 (let* ((pv-cell (when pv-table
1063 (get-pv-cell method-args pv-table
)))
1064 (nm (car next-methods
))
1065 (nms (cdr next-methods
))
1068 :function
(if (std-instance-p nm
)
1069 (method-function nm
)
1071 :call-method-args
(list nms
)))))
1072 (apply fmf pv-cell nmc method-args
))))
1073 ;; FIXME: this looks dangerous.
1074 (let* ((fname (%fun-name fmf
)))
1075 (when (and fname
(eq (car fname
) 'fast-method
))
1076 (set-fun-name method-function
(cons 'slow-method
(cdr fname
)))))
1079 ;;; this is similar to the above, only not quite. Only called when
1080 ;;; the MOP is heavily involved. Not quite parallel to
1081 ;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
1082 ;;; over the actual PV-CELL in this case.
1083 (defun method-function-from-fast-method-call (fmc)
1084 (let* ((fmf (fast-method-call-function fmc
))
1085 (pv-cell (fast-method-call-pv-cell fmc
))
1086 (arg-info (fast-method-call-arg-info fmc
))
1087 (nreq (car arg-info
))
1088 (restp (cdr arg-info
)))
1089 (lambda (method-args next-methods
)
1090 (let* ((nm (car next-methods
))
1091 (nms (cdr next-methods
))
1094 :function
(if (std-instance-p nm
)
1095 (method-function nm
)
1097 :call-method-args
(list nms
)))))
1098 (apply fmf pv-cell nmc method-args
)))))
1100 (defun get-pv-cell (method-args pv-table
)
1101 (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args
)))
1103 (pv-table-lookup pv-table pv-wrappers
))))
1105 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters
)
1106 (pv-table-lookup pv-table
(pv-wrappers-from-pv-args pv-parameters
)))
1108 (defun pv-wrappers-from-pv-args (&rest args
)
1110 (dolist (arg args
(if (cdr wrappers
) (nreverse wrappers
) (car wrappers
)))
1111 (let ((wrapper (wrapper-of arg
)))
1112 (push (if (invalid-wrapper-p wrapper
)
1113 (check-wrapper-validity wrapper
)
1117 (defun pv-wrappers-from-all-args (pv-table args
)
1118 (loop for snl in
(pv-table-slot-name-lists pv-table
) and arg in args
1120 collect
(wrapper-of arg
) into wrappers
1121 finally
(return (if (cdr wrappers
) wrappers
(car wrappers
)))))
1123 ;;; Return the subset of WRAPPERS which is used in the cache
1125 (defun pv-wrappers-from-all-wrappers (pv-table wrappers
)
1126 (loop for snl in
(pv-table-slot-name-lists pv-table
) and w in wrappers
1128 collect w into result
1129 finally
(return (if (cdr result
) result
(car result
)))))