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 (defvar *pvs
* (make-hash-table :test
'equal
))
137 (defun optimize-slot-value-by-class-p (class slot-name type
)
138 (or (not (eq *boot-state
* 'complete
))
139 (let ((slotd (find-slot-definition class slot-name
)))
141 (slot-accessor-std-p slotd type
)))))
143 (defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell
)
144 (if (symbolp slot-name
)
145 (when (optimize-slot-value-by-class-p class slot-name
'all
)
146 (or (instance-slot-index wrapper slot-name
)
147 (let ((cell (assq slot-name class-slots
)))
149 (setf (car class-slot-p-cell
) t
)
151 (when (consp slot-name
)
152 (dolist (type '(reader writer
) nil
)
153 (when (eq (car slot-name
) type
)
155 (let* ((gf-name (cadr slot-name
))
156 (gf (gdefinition gf-name
))
157 (location (when (eq *boot-state
* 'complete
)
158 (accessor-values1 gf type class
))))
159 (when (consp location
)
160 (setf (car class-slot-p-cell
) t
))
163 (defun compute-pv (slot-name-lists wrappers
)
164 (unless (listp wrappers
) (setq wrappers
(list wrappers
)))
165 (let* ((not-simple-p-cell (list nil
))
167 (let ((elements nil
))
168 (dolist (slot-names slot-name-lists
)
170 (let* ((wrapper (pop wrappers
))
171 (std-p (typep wrapper
'wrapper
))
172 (class (wrapper-class* wrapper
))
173 (class-slots (and std-p
(wrapper-class-slots wrapper
))))
174 (dolist (slot-name (cdr slot-names
))
175 ;; Original PCL code had this idiom. why not:
180 (compute-pv-slot slot-name wrapper class
181 class-slots not-simple-p-cell
))
183 (nreverse elements
))))
184 (if (car not-simple-p-cell
)
185 (make-permutation-vector (cons t elements
))
186 (or (gethash elements
*pvs
*)
187 (setf (gethash elements
*pvs
*)
188 (make-permutation-vector (cons nil elements
)))))))
190 (defun compute-calls (call-list wrappers
)
191 (declare (ignore call-list wrappers
))
195 (compute-emf-from-wrappers call wrappers
))
200 #||
; Need to finish this, then write the maintenance functions.
201 (defun compute-emf-from-wrappers (call wrappers
)
203 (destructuring-bind (gf-name nreq restp arg-info
) call
204 (if (eq gf-name
'make-instance
)
205 (error "should not get here") ; there is another mechanism for this.
207 (if (not (eq *boot-state
* 'complete
))
208 (apply (gdefinition gf-name
) args
)
209 (let* ((gf (gdefinition gf-name
))
210 (arg-info (arg-info-reader gf
))
213 (emf (cache-miss-values-internal gf arg-info
214 wrappers classes types
216 (update-all-pv-tables call wrappers emf
)
217 (invoke-emf emf args
))))))))
220 (defun make-permutation-vector (indexes)
221 (make-array (length indexes
) :initial-contents indexes
))
223 (defun pv-table-lookup (pv-table pv-wrappers
)
224 (let* ((slot-name-lists (pv-table-slot-name-lists pv-table
))
225 (call-list (pv-table-call-list pv-table
))
226 (cache (or (pv-table-cache pv-table
)
227 (setf (pv-table-cache pv-table
)
228 (get-cache (- (length slot-name-lists
)
229 (count nil slot-name-lists
))
233 (or (probe-cache cache pv-wrappers
)
234 (let* ((pv (compute-pv slot-name-lists pv-wrappers
))
235 (calls (compute-calls call-list pv-wrappers
))
236 (pv-cell (cons pv calls
))
237 (new-cache (fill-cache cache pv-wrappers pv-cell
)))
238 (unless (eq new-cache cache
)
239 (setf (pv-table-cache pv-table
) new-cache
))
242 (defun make-pv-type-declaration (var)
243 `(type simple-vector
,var
))
245 (defmacro pvref
(pv index
)
248 (defmacro copy-pv
(pv)
251 (defun make-calls-type-declaration (var)
252 `(type simple-vector
,var
))
254 (defmacro callsref
(calls index
)
255 `(svref ,calls
,index
))
257 (defvar *pv-table-cache-update-info
* nil
)
259 (defun update-pv-table-cache-info (class)
260 (let ((slot-names-for-pv-table-update nil
)
262 (dolist (icu *pv-table-cache-update-info
*)
263 (if (eq (car icu
) class
)
264 (pushnew (cdr icu
) slot-names-for-pv-table-update
)
265 (push icu new-icui
)))
266 (setq *pv-table-cache-update-info
* new-icui
)
267 (when slot-names-for-pv-table-update
268 (update-all-pv-table-caches class slot-names-for-pv-table-update
))))
270 (defun update-all-pv-table-caches (class slot-names
)
271 (let* ((cwrapper (class-wrapper class
))
272 (std-p (typep cwrapper
'wrapper
))
273 (class-slots (and std-p
(wrapper-class-slots cwrapper
)))
274 (class-slot-p-cell (list nil
))
275 (new-values (mapcar (lambda (slot-name)
279 slot-name cwrapper class
280 class-slots class-slot-p-cell
))))
283 (dolist (slot-name slot-names
)
284 (map-pv-table-references-of
286 (lambda (pv-table pv-offset-list
)
287 (declare (ignore pv-offset-list
))
288 (pushnew pv-table pv-tables
))))
289 (dolist (pv-table pv-tables
)
290 (let* ((cache (pv-table-cache pv-table
))
291 (slot-name-lists (pv-table-slot-name-lists pv-table
))
292 (pv-size (pv-table-pv-size pv-table
))
293 (pv-map (make-array pv-size
:initial-element nil
)))
294 (let ((map-index 1) (param-index 0))
295 (dolist (slot-name-list slot-name-lists
)
296 (dolist (slot-name (cdr slot-name-list
))
297 (let ((a (assoc slot-name new-values
)))
298 (setf (svref pv-map map-index
)
299 (and a
(cons param-index
(cdr a
)))))
303 (map-cache (lambda (wrappers pv-cell
)
305 (update-slots-in-pv wrappers
(car pv-cell
)
306 cwrapper pv-size pv-map
)))
309 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map
)
310 (if (not (if (atom wrappers
)
311 (eq cwrapper wrappers
)
312 (dolist (wrapper wrappers nil
)
313 (when (eq wrapper cwrapper
)
316 (let* ((old-intern-p (listp (pvref pv
0)))
317 (new-pv (if old-intern-p
322 (dotimes-fixnum (i pv-size
)
323 (when (consp (let ((map (svref pv-map i
)))
325 (setf (pvref new-pv i
) (cdr map
))
327 (setq new-intern-p nil
)))
329 (dolist (wrapper wrappers
)
330 (when (eq wrapper cwrapper
)
331 (dotimes-fixnum (i pv-size
)
332 (when (consp (let ((map (svref pv-map i
)))
333 (if (and map
(= (car map
) param
))
334 (setf (pvref new-pv i
) (cdr map
))
336 (setq new-intern-p nil
))))
339 (setq new-pv
(let ((list-pv (coerce pv
'list
)))
340 (or (gethash (cdr list-pv
) *pvs
*)
341 (setf (gethash (cdr list-pv
) *pvs
*)
344 (make-permutation-vector list-pv
)))))))
347 (defun maybe-expand-accessor-form (form required-parameters slots env
)
348 (let* ((fname (car form
))
349 #||
(len (length form
))||
#
350 (gf (if (symbolp fname
)
351 (unencapsulated-fdefinition fname
)
352 (gdefinition fname
))))
353 (macrolet ((maybe-optimize-reader ()
355 (can-optimize-access1 (cadr form
)
356 required-parameters env
)))
358 (optimize-reader slots parameter gf-name form
))))
359 (maybe-optimize-writer ()
361 (can-optimize-access1 (caddr form
)
362 required-parameters env
)))
364 (optimize-writer slots parameter gf-name form
)))))
365 (unless (and (consp (cadr form
))
366 (eq 'instance-accessor-parameter
(caadr form
)))
367 (when (and (eq *boot-state
* 'complete
)
368 (generic-function-p gf
))
369 (let ((methods (generic-function-methods gf
)))
371 (let* ((gf-name (generic-function-name gf
))
372 (arg-info (gf-arg-info gf
))
373 (metatypes (arg-info-metatypes arg-info
))
374 (nreq (length metatypes
))
375 (applyp (arg-info-applyp arg-info
)))
378 (when (some #'standard-reader-method-p methods
)
379 (maybe-optimize-reader)))
382 (eq (car gf-name
) 'setf
))
383 (when (some #'standard-writer-method-p methods
)
384 (maybe-optimize-writer)))))))))))))
386 (defun optimize-generic-function-call (form
391 (declare (ignore required-parameters env slots calls
))
392 (or ; (optimize-reader ...)?
395 (defun can-optimize-access (form required-parameters env
)
396 (let ((type (ecase (car form
)
398 (set-slot-value 'writer
)
399 (slot-boundp 'boundp
)))
401 (slot-name (eval (caddr form
)))) ; known to be constant
402 (can-optimize-access1 var required-parameters env type slot-name
)))
404 ;;; FIXME: This looks like an internal helper function for
405 ;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
406 ;;; bare from several places in the code. Perhaps the two functions
407 ;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
408 ;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
409 ;;; args instead of optional ones, too.
410 (defun can-optimize-access1 (var required-parameters env
411 &optional type slot-name
)
412 (when (and (consp var
) (eq 'the
(car var
)))
413 ;; FIXME: We should assert list of length 3 here. Or maybe we
414 ;; should just define EXTRACT-THE, replace the whole
417 ;; (AWHEN (EXTRACT-THE VAR)
419 ;; and then use EXTRACT-THE similarly to clean up the other tests
420 ;; against 'THE scattered through the PCL code.
421 (setq var
(caddr var
)))
423 (let* ((rebound?
(caddr (var-declaration '%variable-rebinding var env
)))
424 (parameter-or-nil (car (memq (or rebound? var
)
425 required-parameters
))))
426 (when parameter-or-nil
427 (let* ((class-name (caddr (var-declaration '%class
430 (class (find-class class-name nil
)))
431 (when (or (not (eq *boot-state
* 'complete
))
432 (and class
(not (class-finalized-p class
))))
434 (when (and class-name
(not (eq class-name t
)))
435 (when (or (null type
)
437 (memq *the-class-structure-object
*
438 (class-precedence-list class
))))
439 (optimize-slot-value-by-class-p class slot-name type
))
440 (cons parameter-or-nil
(or class class-name
)))))))))
442 (defun optimize-slot-value (slots sparameter form
)
444 (destructuring-bind (ignore1 ignore2 slot-name-form
) form
445 (declare (ignore ignore1 ignore2
))
446 (let ((slot-name (eval slot-name-form
)))
447 (optimize-instance-access slots
:read sparameter slot-name nil
)))
448 `(accessor-slot-value ,@(cdr form
))))
450 (defun optimize-set-slot-value (slots sparameter form
)
452 (destructuring-bind (ignore1 ignore2 slot-name-form new-value
) form
453 (declare (ignore ignore1 ignore2
))
454 (let ((slot-name (eval slot-name-form
)))
455 (optimize-instance-access slots
460 `(accessor-set-slot-value ,@(cdr form
))))
462 (defun optimize-slot-boundp (slots sparameter form
)
465 ;; FIXME: In CMU CL ca. 19991205, this binding list had a
466 ;; fourth element in it, NEW-VALUE. It's hard to see how
467 ;; that could possibly be right, since SLOT-BOUNDP has no
468 ;; NEW-VALUE. Since it was causing a failure in building PCL
469 ;; for SBCL, so I changed it to match the definition of
470 ;; SLOT-BOUNDP (and also to match the list used in the
471 ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded
472 ;; out by this, since this is old code which has worked for
473 ;; ages to build PCL for CMU CL, so it's hard to see why it
474 ;; should need a patch like this in order to build PCL for
475 ;; SBCL. I'd like to return to this and find a test case
476 ;; which exercises this function both in CMU CL, to see
477 ;; whether it's really a previously-unexercised bug or
478 ;; whether I've misunderstood something (and, presumably,
479 ;; patched it wrong).
480 (slot-boundp-symbol instance slot-name-form
)
482 (declare (ignore slot-boundp-symbol instance
))
483 (let ((slot-name (eval slot-name-form
)))
484 (optimize-instance-access slots
489 `(accessor-slot-boundp ,@(cdr form
))))
491 (defun optimize-reader (slots sparameter gf-name form
)
493 (optimize-accessor-call slots
:read sparameter gf-name nil
)
496 (defun optimize-writer (slots sparameter gf-name form
)
498 (destructuring-bind (ignore1 ignore2 new-value
) form
499 (declare (ignore ignore1 ignore2
))
500 (optimize-accessor-call slots
:write sparameter gf-name new-value
))
503 ;;; The SLOTS argument is an alist, the CAR of each entry is the name
504 ;;; of a required parameter to the function. The alist is in order, so
505 ;;; the position of an entry in the alist corresponds to the
506 ;;; argument's position in the lambda list.
507 (defun optimize-instance-access (slots
512 (let ((class (if (consp sparameter
) (cdr sparameter
) *the-class-t
*))
513 (parameter (if (consp sparameter
) (car sparameter
) sparameter
)))
514 (if (and (eq *boot-state
* 'complete
)
516 (memq *the-class-structure-object
* (class-precedence-list class
)))
517 (let ((slotd (find-slot-definition class slot-name
)))
520 `(,(slot-definition-defstruct-accessor-symbol slotd
) ,parameter
))
522 `(setf (,(slot-definition-defstruct-accessor-symbol slotd
)
527 (let* ((parameter-entry (assq parameter slots
))
528 (slot-entry (assq slot-name
(cdr parameter-entry
)))
529 (position (posq parameter-entry slots
))
530 (pv-offset-form (list 'pv-offset
''.PV-OFFSET.
)))
531 (unless parameter-entry
532 (bug "slot optimization bewilderment: O-I-A"))
534 (setq slot-entry
(list slot-name
))
535 (push slot-entry
(cdr parameter-entry
)))
536 (push pv-offset-form
(cdr slot-entry
))
539 `(instance-read ,pv-offset-form
,parameter
,position
540 ',slot-name
',class
))
542 `(let ((.new-value.
,new-value
))
543 (instance-write ,pv-offset-form
,parameter
,position
544 ',slot-name
',class .new-value.
)))
546 `(instance-boundp ,pv-offset-form
,parameter
,position
547 ',slot-name
',class
)))))))
549 (defun optimize-accessor-call (slots read
/write sparameter gf-name new-value
)
550 (let* ((class (if (consp sparameter
) (cdr sparameter
) *the-class-t
*))
551 (parameter (if (consp sparameter
) (car sparameter
) sparameter
))
552 (parameter-entry (assq parameter slots
))
553 (name (case read
/write
554 (:read
`(reader ,gf-name
))
555 (:write
`(writer ,gf-name
))))
556 (slot-entry (assoc name
(cdr parameter-entry
) :test
#'equal
))
557 (position (posq parameter-entry slots
))
558 (pv-offset-form (list 'pv-offset
''.PV-OFFSET.
)))
559 (unless parameter-entry
560 (error "slot optimization bewilderment: O-A-C"))
562 (setq slot-entry
(list name
))
563 (push slot-entry
(cdr parameter-entry
)))
564 (push pv-offset-form
(cdr slot-entry
))
567 `(instance-reader ,pv-offset-form
,parameter
,position
,gf-name
',class
))
569 `(let ((.new-value.
,new-value
))
570 (instance-writer ,pv-offset-form
,parameter
,position
,gf-name
',class
573 (defvar *unspecific-arg
* '..unspecific-arg..
)
575 (defun optimize-gf-call-internal (form slots env
)
576 (when (and (consp form
)
577 (eq (car form
) 'the
))
578 (setq form
(caddr form
)))
579 (or (and (symbolp form
)
580 (let* ((rebound?
(caddr (var-declaration '%variable-rebinding
583 (parameter-or-nil (car (assq (or rebound? form
) slots
))))
584 (when parameter-or-nil
585 (let* ((class-name (caddr (var-declaration 'class
588 (when (and class-name
(not (eq class-name t
)))
589 (position parameter-or-nil slots
:key
#'car
))))))
591 (let ((form (constant-form-value form
)))
597 (defun optimize-gf-call (slots calls gf-call-form nreq restp env
)
598 (unless (eq (car gf-call-form
) 'make-instance
) ; XXX needs more work
599 (let* ((args (cdr gf-call-form
))
600 (all-args-p (eq (car gf-call-form
) 'make-instance
))
601 (non-required-args (nthcdr nreq args
))
602 (required-args (ldiff args non-required-args
))
603 (call-spec (list (car gf-call-form
) nreq restp
604 (mapcar (lambda (form)
605 (optimize-gf-call-internal form slots env
))
609 (call-entry (assoc call-spec calls
:test
#'equal
))
610 (pv-offset-form (list 'pv-offset
''.PV-OFFSET.
)))
611 (unless (some #'integerp
612 (let ((spec-args (cdr call-spec
)))
614 (ldiff spec-args
(nthcdr nreq spec-args
))
616 (return-from optimize-gf-call nil
))
618 (setq call-entry
(list call-spec
))
619 (push call-entry
(cdr calls
)))
620 (push pv-offset-form
(cdr call-entry
))
621 (if (eq (car call-spec
) 'make-instance
)
622 `(funcall (pv-ref .pv.
,pv-offset-form
) ,@(cdr gf-call-form
))
623 `(let ((.emf.
(pv-ref .pv.
,pv-offset-form
)))
624 (invoke-effective-method-function .emf.
,restp
625 ,@required-args
,@(when restp
`((list ,@non-required-args
)))))))))
627 (define-walker-template pv-offset
) ; These forms get munged by mutate slots.
628 (defmacro pv-offset
(arg) arg
)
629 (define-walker-template instance-accessor-parameter
)
630 (defmacro instance-accessor-parameter
(x) x
)
632 ;;; It is safe for these two functions to be wrong. They just try to
633 ;;; guess what the most likely case will be.
634 (defun generate-fast-class-slot-access-p (class-form slot-name-form
)
635 (let ((class (and (constantp class-form
) (constant-form-value class-form
)))
636 (slot-name (and (constantp slot-name-form
)
637 (constant-form-value slot-name-form
))))
638 (and (eq *boot-state
* 'complete
)
639 (standard-class-p class
)
640 (not (eq class
*the-class-t
*)) ; shouldn't happen, though.
641 (let ((slotd (find-slot-definition class slot-name
)))
642 (and slotd
(eq :class
(slot-definition-allocation slotd
)))))))
644 (defun skip-fast-slot-access-p (class-form slot-name-form type
)
645 (let ((class (and (constantp class-form
) (constant-form-value class-form
)))
646 (slot-name (and (constantp slot-name-form
)
647 (constant-form-value slot-name-form
))))
648 (and (eq *boot-state
* 'complete
)
649 (standard-class-p class
)
650 (not (eq class
*the-class-t
*)) ; shouldn't happen, though.
651 (let ((slotd (find-slot-definition class slot-name
)))
652 (and slotd
(skip-optimize-slot-value-by-class-p class
656 (defun skip-optimize-slot-value-by-class-p (class slot-name type
)
657 (let ((slotd (find-slot-definition class slot-name
)))
659 (eq *boot-state
* 'complete
)
660 (not (slot-accessor-std-p slotd type
)))))
662 (defmacro instance-read-internal
(pv slots pv-offset default
&optional type
)
663 (unless (member type
'(nil :instance
:class
:default
))
664 (error "illegal type argument to ~S: ~S" 'instance-read-internal type
))
665 (if (eq type
:default
)
667 (let* ((index (gensym))
669 `(locally (declare #.
*optimize-speed
*)
670 (let ((,index
(pvref ,pv
,pv-offset
)))
671 (setq ,value
(typecase ,index
672 ;; FIXME: the line marked by KLUDGE below
673 ;; (and the analogous spot in
674 ;; INSTANCE-WRITE-INTERNAL) is there purely
675 ;; to suppress a type mismatch warning that
676 ;; propagates through to user code.
677 ;; Presumably SLOTS at this point can never
678 ;; actually be NIL, but the compiler seems
679 ;; to think it could, so we put this here
680 ;; to shut it up. (see also mail Rudi
681 ;; Schlatte sbcl-devel 2003-09-21) -- CSR,
683 ,@(when (or (null type
) (eq type
:instance
))
686 (clos-slots-ref ,slots
,index
)))))
687 ,@(when (or (null type
) (eq type
:class
))
688 `((cons (cdr ,index
))))
690 (if (eq ,value
+slot-unbound
+)
694 (defmacro instance-read
(pv-offset parameter position slot-name class
)
695 (if (skip-fast-slot-access-p class slot-name
'reader
)
696 `(accessor-slot-value ,parameter
,slot-name
)
697 `(instance-read-internal .pv.
,(slot-vector-symbol position
)
698 ,pv-offset
(accessor-slot-value ,parameter
,slot-name
)
699 ,(if (generate-fast-class-slot-access-p class slot-name
)
702 (defmacro instance-reader
(pv-offset parameter position gf-name class
)
703 (declare (ignore class
))
704 `(instance-read-internal .pv.
,(slot-vector-symbol position
)
706 (,gf-name
(instance-accessor-parameter ,parameter
))
709 (defmacro instance-write-internal
(pv slots pv-offset new-value default
711 (unless (member type
'(nil :instance
:class
:default
))
712 (error "illegal type argument to ~S: ~S" 'instance-write-internal type
))
713 (if (eq type
:default
)
715 (let* ((index (gensym)))
716 `(locally (declare #.
*optimize-speed
*)
717 (let ((,index
(pvref ,pv
,pv-offset
)))
719 ,@(when (or (null type
) (eq type
:instance
))
720 `((fixnum (and ,slots
721 (setf (clos-slots-ref ,slots
,index
)
723 ,@(when (or (null type
) (eq type
:class
))
724 `((cons (setf (cdr ,index
) ,new-value
))))
727 (defmacro instance-write
(pv-offset
733 (if (skip-fast-slot-access-p class slot-name
'writer
)
734 `(accessor-set-slot-value ,parameter
,slot-name
,new-value
)
735 `(instance-write-internal .pv.
,(slot-vector-symbol position
)
736 ,pv-offset
,new-value
737 (accessor-set-slot-value ,parameter
,slot-name
,new-value
)
738 ,(if (generate-fast-class-slot-access-p class slot-name
)
741 (defmacro instance-writer
(pv-offset
747 (declare (ignore class
))
748 `(instance-write-internal .pv.
,(slot-vector-symbol position
)
749 ,pv-offset
,new-value
750 (,(if (consp gf-name
)
751 (get-setf-fun-name gf-name
)
753 (instance-accessor-parameter ,parameter
)
757 (defmacro instance-boundp-internal
(pv slots pv-offset default
759 (unless (member type
'(nil :instance
:class
:default
))
760 (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type
))
761 (if (eq type
:default
)
763 (let* ((index (gensym)))
764 `(locally (declare #.
*optimize-speed
*)
765 (let ((,index
(pvref ,pv
,pv-offset
)))
767 ,@(when (or (null type
) (eq type
:instance
))
768 `((fixnum (not (and ,slots
769 (eq (clos-slots-ref ,slots
,index
)
771 ,@(when (or (null type
) (eq type
:class
))
772 `((cons (not (eq (cdr ,index
) +slot-unbound
+)))))
775 (defmacro instance-boundp
(pv-offset parameter position slot-name class
)
776 (if (skip-fast-slot-access-p class slot-name
'boundp
)
777 `(accessor-slot-boundp ,parameter
,slot-name
)
778 `(instance-boundp-internal .pv.
,(slot-vector-symbol position
)
779 ,pv-offset
(accessor-slot-boundp ,parameter
,slot-name
)
780 ,(if (generate-fast-class-slot-access-p class slot-name
)
783 ;;; This magic function has quite a job to do indeed.
785 ;;; The careful reader will recall that <slots> contains all of the
786 ;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS.
787 ;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE.
789 ;;; At the time these calls were produced, the first argument was
790 ;;; specified as the symbol .PV-OFFSET.; what we have to do now is
791 ;;; convert those pv-offset arguments into the actual number that is
792 ;;; the correct offset into the pv.
794 ;;; But first, oh but first, we sort <slots> a bit so that for each
795 ;;; argument we have the slots in alphabetical order. This
796 ;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
797 ;;; having fewer PV's floating around. Even if the gain is only
798 ;;; modest, it costs nothing.
799 (defun slot-name-lists-from-slots (slots calls
)
800 (multiple-value-bind (slots calls
) (mutate-slots-and-calls slots calls
)
801 (let* ((slot-name-lists
802 (mapcar (lambda (parameter-entry)
803 (cons nil
(mapcar #'car
(cdr parameter-entry
))))
806 (mapcar #'car calls
)))
807 (dolist (call call-list
)
808 (dolist (arg (cdr call
))
810 (setf (car (nth arg slot-name-lists
)) t
))))
811 (setq slot-name-lists
(mapcar (lambda (r+snl
)
812 (when (or (car r
+snl
) (cdr r
+snl
))
815 (let ((cvt (apply #'vector
817 (mapcar (lambda (r+snl
)
818 (when r
+snl
(incf i
)))
820 (setq call-list
(mapcar (lambda (call)
822 (mapcar (lambda (arg)
828 (values slot-name-lists call-list
))))
830 (defun mutate-slots-and-calls (slots calls
)
831 (let ((sorted-slots (sort-slots slots
))
832 (sorted-calls (sort-calls (cdr calls
)))
833 (pv-offset 0)) ; index 0 is for info
834 (dolist (parameter-entry sorted-slots
)
835 (dolist (slot-entry (cdr parameter-entry
))
837 (dolist (form (cdr slot-entry
))
838 (setf (cadr form
) pv-offset
))))
839 (dolist (call-entry sorted-calls
)
841 (dolist (form (cdr call-entry
))
842 (setf (cadr form
) pv-offset
)))
843 (values sorted-slots sorted-calls
)))
845 (defun symbol-pkg-name (sym)
846 (let ((pkg (symbol-package sym
)))
847 (if pkg
(package-name pkg
) "")))
849 ;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
850 ;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
851 ;;; stable. This ordering is only used in to
852 ;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
853 ;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
854 ;;; floating around", so it sounds as though the instability won't
855 ;;; actually lead to bugs, just small inefficiency. But still, it
856 ;;; would be better to reimplement this function as a comparison based
858 ;;; * stable comparison
859 ;;; * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
861 (defun symbol-lessp (a b
)
862 (if (eq (symbol-package a
)
864 (string-lessp (symbol-name a
)
866 (string-lessp (symbol-pkg-name a
)
867 (symbol-pkg-name b
))))
869 (defun symbol-or-cons-lessp (a b
)
872 (symbol (symbol-lessp a b
))
876 (cons (if (eq (car a
) (car b
))
877 (symbol-or-cons-lessp (cdr a
) (cdr b
))
878 (symbol-or-cons-lessp (car a
) (car b
))))))))
880 (defun sort-slots (slots)
881 (mapcar (lambda (parameter-entry)
882 (cons (car parameter-entry
)
883 (sort (cdr parameter-entry
) ;slot entries
884 #'symbol-or-cons-lessp
888 (defun sort-calls (calls)
889 (sort calls
#'symbol-or-cons-lessp
:key
#'car
))
891 ;;;; This needs to work in terms of metatypes and also needs to work
892 ;;;; for automatically generated reader and writer functions.
893 ;;;; Automatically generated reader and writer functions use this
896 (defmacro pv-binding
((required-parameters slot-name-lists pv-table-symbol
)
898 (let (slot-vars pv-parameters
)
899 (loop for slots in slot-name-lists
900 for required-parameter in required-parameters
903 (push required-parameter pv-parameters
)
904 (push (slot-vector-symbol i
) slot-vars
)))
905 `(pv-binding1 (.pv. .calls.
,pv-table-symbol
906 ,(nreverse pv-parameters
) ,(nreverse slot-vars
))
909 (defmacro pv-binding1
((pv calls pv-table-symbol pv-parameters slot-vars
)
911 `(pv-env (,pv
,calls
,pv-table-symbol
,pv-parameters
)
912 (let (,@(mapcar (lambda (slot-var p
) `(,slot-var
(get-slots-or-nil ,p
)))
913 slot-vars pv-parameters
))
914 (declare (ignorable ,@(mapcar #'identity slot-vars
)))
917 ;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is
919 (define-symbol-macro pv-env-environment overridden
)
921 (defmacro pv-env
(&environment env
922 (pv calls pv-table-symbol pv-parameters
)
924 ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
926 (if (eq (macroexpand 'pv-env-environment env
) 'default
)
927 `(let ((,pv
(car .pv-cell.
))
928 (,calls
(cdr .pv-cell.
)))
929 (declare ,(make-pv-type-declaration pv
)
930 ,(make-calls-type-declaration calls
))
934 ,@(when (symbolp pv-table-symbol
)
935 `((declare (special ,pv-table-symbol
))))
936 (let* ((.pv-table.
,pv-table-symbol
)
937 (.pv-cell.
(pv-table-lookup-pv-args .pv-table.
,@pv-parameters
))
938 (,pv
(car .pv-cell.
))
939 (,calls
(cdr .pv-cell.
)))
940 (declare ,(make-pv-type-declaration pv
))
941 (declare ,(make-calls-type-declaration calls
))
945 (defvar *non-var-declarations
*
946 ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
947 ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
948 ;; SBCL doesn't have 'em, VALUES should probably be removed from
958 (defvar *var-declarations-with-arg
*
962 (defvar *var-declarations-without-arg
*
964 ignorable special dynamic-extent
965 ;; FIXME: Possibly this entire list and variable could go away.
966 ;; If not, certainly we should remove all these built-in typenames
967 ;; from the list, and replace them with a test for "is it a type
968 ;; name?" (CLTL1 allowed only built-in type names as declarations,
969 ;; but ANSI CL allows any type name as a declaration.)
970 array atom base-char bignum bit bit-vector character compiled-function
971 complex cons double-float extended-char
972 fixnum float function hash-table integer
973 keyword list long-float nil null number package pathname random-state ratio
974 rational readtable sequence short-float signed-byte simple-array
975 simple-bit-vector simple-string simple-vector single-float standard-char
976 stream string symbol t unsigned-byte vector
))
978 (defun split-declarations (body args maybe-reads-params-p
)
979 (let ((inner-decls nil
)
982 (loop (when (null body
) (return nil
))
983 (setq decl
(car body
))
984 (unless (and (consp decl
)
985 (eq (car decl
) 'declare
))
987 (dolist (form (cdr decl
))
989 (let ((declaration-name (car form
)))
990 (if (member declaration-name
*non-var-declarations
*)
991 (push `(declare ,form
) outer-decls
)
993 (member declaration-name
994 *var-declarations-with-arg
*))
996 (member declaration-name
997 *var-declarations-without-arg
*))
998 (dname (list (pop form
)))
999 (inners nil
) (outers nil
))
1000 (unless (or arg-p non-arg-p
)
1001 ;; FIXME: This warning, and perhaps the
1002 ;; various *VAR-DECLARATIONS-FOO* and/or
1003 ;; *NON-VAR-DECLARATIONS* variables,
1004 ;; could probably go away now that we're not
1005 ;; trying to be portable between different
1006 ;; CLTL1 hosts the way PCL was. (Note that to
1007 ;; do this right, we need to be able to handle
1008 ;; user-defined (DECLAIM (DECLARATION FOO))
1010 (warn "The declaration ~S is not understood by ~S.~@
1011 Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
1012 (Assuming it is a variable declaration without argument)."
1013 declaration-name
'split-declarations
1015 '*non-var-declarations
*
1016 '*var-declarations-with-arg
*
1017 '*var-declarations-without-arg
*)
1018 (push declaration-name
*var-declarations-without-arg
*))
1020 (setq dname
(append dname
(list (pop form
)))))
1022 (%class
(push `(declare (,@dname
,@form
)) inner-decls
))
1025 (if (member var args
)
1026 ;; Quietly remove IGNORE declarations
1027 ;; on args when a next-method is
1028 ;; involved, to prevent compiler
1029 ;; warnings about ignored args being
1031 (unless (and maybe-reads-params-p
1032 (eq (car dname
) 'ignore
))
1036 (push `(declare (,@dname
,@outers
)) outer-decls
))
1039 `(declare (,@dname
,@inners
))
1040 inner-decls
)))))))))
1041 (setq body
(cdr body
)))
1042 (values outer-decls inner-decls body
)))
1044 ;;; Pull a name out of the %METHOD-NAME declaration in the function
1045 ;;; body given, or return NIL if no %METHOD-NAME declaration is found.
1046 (defun body-method-name (body)
1047 (multiple-value-bind (real-body declarations documentation
)
1049 (declare (ignore real-body documentation
))
1050 (let ((name-decl (get-declaration '%method-name declarations
)))
1052 (destructuring-bind (name) name-decl
1055 ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
1056 ;;; declaration (which is a naming style internal to PCL) into an
1057 ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
1058 ;;; throughout SBCL, understood by the main compiler); or if there's
1059 ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
1060 ;;; lambda expression.
1061 (defun name-method-lambda (method-lambda)
1062 (let ((method-name (body-method-name (cddr method-lambda
))))
1064 `(named-lambda (slow-method ,method-name
) ,(rest method-lambda
))
1067 (defun make-method-initargs-form-internal (method-lambda initargs env
)
1068 (declare (ignore env
))
1069 (let (method-lambda-args
1070 lmf
; becomes body of function
1072 (if (not (and (= 3 (length method-lambda
))
1073 (= 2 (length (setq method-lambda-args
(cadr method-lambda
))))
1074 (consp (setq lmf
(third method-lambda
)))
1075 (eq 'simple-lexical-method-functions
(car lmf
))
1076 (eq (car method-lambda-args
)
1077 (cadr (setq lmf-params
(cadr lmf
))))
1078 (eq (cadr method-lambda-args
)
1079 (caddr lmf-params
))))
1080 `(list* :function
,(name-method-lambda method-lambda
)
1082 (let* ((lambda-list (car lmf-params
))
1086 (dolist (arg lambda-list
)
1087 (when (member arg
'(&optional
&rest
&key
))
1090 (when (eq arg
'&aux
)
1094 (setq args
(nreverse args
))
1095 (setf (getf (getf initargs
:plist
) :arg-info
) (cons nreq restp
))
1096 (make-method-initargs-form-internal1
1097 initargs
(cddr lmf
) args lmf-params restp
)))))
1099 (defun make-method-initargs-form-internal1
1100 (initargs body req-args lmf-params restp
)
1101 (multiple-value-bind (outer-decls inner-decls body-sans-decls
)
1103 body req-args
(or (getf (cdr lmf-params
) :call-next-method-p
)
1104 (getf (cdr lmf-params
) :setq-p
)))
1105 (let* ((rest-arg (when restp
'.rest-arg.
))
1106 (args+rest-arg
(if restp
1107 (append req-args
(list rest-arg
))
1111 (,(if (body-method-name body
) 'named-lambda
'lambda
)
1112 ,@(when (body-method-name body
)
1114 (list (cons 'fast-method
(body-method-name body
))))
1115 (.pv-cell. .next-method-call.
,@args
+rest-arg
) ; function args
1116 ;; body of the function
1117 (declare (ignorable .pv-cell. .next-method-call.
)
1118 (disable-package-locks pv-env-environment
))
1120 (symbol-macrolet ((pv-env-environment default
))
1121 (fast-lexical-method-functions
1122 (,(car lmf-params
) .next-method-call.
,req-args
,rest-arg
1123 ,@(cdddr lmf-params
))
1125 ,@body-sans-decls
)))
1128 ;;; Use arrays and hash tables and the fngen stuff to make this much
1129 ;;; better. It doesn't really matter, though, because a function
1130 ;;; returned by this will get called only when the user explicitly
1131 ;;; funcalls a result of method-function. BUT, this is needed to make
1132 ;;; early methods work.
1133 (defun method-function-from-fast-function (fmf)
1134 (declare (type function fmf
))
1135 (let* ((method-function nil
) (pv-table nil
)
1136 (arg-info (method-function-get fmf
:arg-info
))
1137 (nreq (car arg-info
))
1138 (restp (cdr arg-info
)))
1139 (setq method-function
1140 (lambda (method-args next-methods
)
1142 (setq pv-table
(method-function-pv-table fmf
)))
1143 (let* ((pv-cell (when pv-table
1144 (get-method-function-pv-cell
1145 method-function method-args pv-table
)))
1146 (nm (car next-methods
))
1147 (nms (cdr next-methods
))
1150 :function
(if (std-instance-p nm
)
1151 (method-function nm
)
1153 :call-method-args
(list nms
)))))
1155 (let* ((rest (nthcdr nreq method-args
))
1156 (args (ldiff method-args rest
)))
1157 (apply fmf pv-cell nmc
(nconc args
(list rest
))))
1158 (apply fmf pv-cell nmc method-args
)))))
1159 (let* ((fname (method-function-get fmf
:name
))
1160 (name (cons 'slow-method
(cdr fname
))))
1161 (set-fun-name method-function name
))
1162 (setf (method-function-get method-function
:fast-function
) fmf
)
1165 (defun get-method-function-pv-cell (method-function
1168 (let ((pv-table (or pv-table
(method-function-pv-table method-function
))))
1170 (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args
)))
1172 (pv-table-lookup pv-table pv-wrappers
))))))
1174 (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters
)
1175 (pv-table-lookup pv-table
(pv-wrappers-from-pv-args pv-parameters
)))
1177 (defun pv-wrappers-from-pv-args (&rest args
)
1179 (dolist (arg args
(if (cdr wrappers
) (nreverse wrappers
) (car wrappers
)))
1180 (let ((wrapper (wrapper-of arg
)))
1181 (push (if (invalid-wrapper-p wrapper
)
1182 (check-wrapper-validity wrapper
)
1186 (defun pv-wrappers-from-all-args (pv-table args
)
1187 (loop for snl in
(pv-table-slot-name-lists pv-table
) and arg in args
1189 collect
(wrapper-of arg
) into wrappers
1190 finally
(return (if (cdr wrappers
) wrappers
(car wrappers
)))))
1192 ;;; Return the subset of WRAPPERS which is used in the cache
1194 (defun pv-wrappers-from-all-wrappers (pv-table wrappers
)
1195 (loop for snl in
(pv-table-slot-name-lists pv-table
) and w in wrappers
1197 collect w into result
1198 finally
(return (if (cdr result
) result
(car result
)))))