/[cmucl]/src/pcl/method-slot-access-optimization.lisp
ViewVC logotype

Contents of /src/pcl/method-slot-access-optimization.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Mon Apr 19 02:31:14 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.8: +4 -4 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de>
2 ;;; All rights reserved.
3 ;;;
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
6 ;;; are met:
7 ;;;
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote
14 ;;; products derived from this software without specific prior written
15 ;;; permission.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
21 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
23 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
24 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
26 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
27 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
28 ;;; DAMAGE.
29
30 ;;; ***************
31 ;;; Overview *****
32 ;;; ***************
33 ;;;
34 ;;; Code generation for optimized slot access in methods.
35 ;;;
36 ;;; Parts of this code may be derived from code in Xerox-PCL's
37 ;;; vector.lisp, although heavily rewritten. See vector.lisp for
38 ;;; Xerox' copyright and licensing information.
39 ;;;
40 ;;; ********************
41 ;;; Entry Points ******
42 ;;; ********************
43 ;;;
44 ;;; OPTIMIZE-SLOT-ACCESS, OPTIMIZE-SLOT-READER, OPTIMIZE-SLOT-WRITER
45 ;;; are called from WALK-METHOD-LAMBDA.
46 ;;;
47 ;;; *******************
48 ;;; To Do/Ideas ******
49 ;;; *******************
50 ;;;
51 ;;; - Prevent PV lookup if only inline access is done?
52 ;;;
53
54 (file-comment
55 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/method-slot-access-optimization.lisp,v 1.9 2010/04/19 02:31:14 rtoy Rel $")
56
57 (in-package "PCL")
58 (intl:textdomain "cmucl")
59
60 (defvar *optimize-inline-slot-access-p* t
61 "Set to true to activate the inline slot access optimization.")
62
63 (defvar *use-slot-types-p* t
64 "When true, check slot values against specified slot types.")
65
66 (defvar *optimize-accessor-calls-p* t
67 "When true, optimize slot access through slot reader/writer functions.")
68
69
70 ;;; *******************
71 ;;; Conditions *******
72 ;;; *******************
73
74 (define-condition slot-access-warning (simple-warning)
75 ((class :reader slot-access-warning-class :initarg :class)
76 (title :reader slot-access-warning-title :initarg :title))
77 (:report (lambda (condition stream)
78 (format stream
79 (format nil "~~@<~a ~s. ~?~~@:>"
80 (slot-access-warning-title condition)
81 (slot-access-warning-class condition)
82 (simple-condition-format-control condition)
83 (simple-condition-format-arguments condition))))))
84
85 (define-condition cant-optimize-warning (slot-access-warning) ())
86 (define-condition method-recompilation-warning (slot-access-warning) ())
87
88 (defun cant-optimize (class format-control &rest format-args)
89 (warn 'cant-optimize-warning
90 :title _"Cannot optimize slot access to"
91 :class class
92 :format-control format-control
93 :format-arguments format-args))
94
95
96 ;;; **************************
97 ;;; Support Functions *******
98 ;;; **************************
99
100 ;;;
101 ;;; This macro is used to make optimized forms which should not be
102 ;;; further optimized recognizable while walking the method body.
103 ;;;
104 (defmacro optimized-marker (x) x)
105 (define-walker-template optimized-marker)
106
107 ;;;
108 ;;; Return the type of slot SLOT-NAME in class CLASS for slot access
109 ;;; optimizations. Return T if no type is specified for the slot.
110 ;;;
111 (defun slot-type (class slot-name)
112 (or (and *use-slot-types-p*
113 (decide-slot-type class slot-name))
114 t))
115
116 ;;;
117 ;;; Add an entry for accessing slot SLOT-NAME through parameter PARAM
118 ;;; to PARAM-SLOTS, if it's not already there. Add PV-OFFSET to the
119 ;;; list of pv offset forms used for accessing SLOT-NAME through PARAM,
120 ;;; if a PV-OFFSET form is specified.
121 ;;;
122 ;;; Value is the name of the variable that will be bound to the slot
123 ;;; vector of PARAM on method entry.
124 ;;;
125 (defun add-param-slot-entry (param slot-name param-slots
126 &optional (pv-offset nil pv-offset-supplied-p))
127 (let* ((param-entry (assoc param param-slots :test #'eq))
128 (slot-entry (assoc slot-name (cdr param-entry)
129 :test (if (symbolp slot-name) #'eq #'equal))))
130 (unless slot-entry
131 (setq slot-entry (list slot-name))
132 (push slot-entry (cdr param-entry)))
133 (when pv-offset-supplied-p
134 (push pv-offset (cdr slot-entry)))
135 (slot-vector-symbol (position param-entry param-slots :test #'eq))))
136
137 ;;;
138 ;;; Return true if PARAM-ENTRY has anything in it required a pv lookup.
139 ;;;
140 (defun pv-optimized-param-p (param-entry)
141 (loop for (slot-name . pv-offsets) in (cdr param-entry)
142 thereis (or (symbolp slot-name)
143 (not (equal '(inline-access) slot-name)))))
144
145
146 ;;; ************************************************************************
147 ;;; ******** Optimizing SLOT-VALUE, SLOT-BOUNDP, (SETF SLOT-VALUE) *******
148 ;;; ************************************************************************
149
150 ;;;
151 ;;; This function is called from WALK-METHOD-LAMBDA for optimizing
152 ;;; SLOT-VALUE, (SETF SLOT-VALUE), and SLOT-BOUNDP.
153 ;;;
154 ;;; FORM is the form to optimize, and ENV is the environment where
155 ;;; the form occurs.
156 ;;;
157 ;;; REQUIRED-PARAMS is a list of the required parameters of the method
158 ;;; in which FORM occurs.
159 ;;;
160 ;;; PARAM-SLOTS is an alist with an entry for each required parameter.
161 ;;; The CAR of each entry is the name of a required parameter to the
162 ;;; method. The CDR of of each entry is a list of (SLOT-NAME
163 ;;; PV-OFFSET ...) lists, where SLOT-NAME is either the name of a
164 ;;; slot, or a pseudo slot name like (READER <gf-name>). Each
165 ;;; PV-OFFSET is a form (PV-OFFSET -1) used in a pv-optimization. The
166 ;;; -1 gets backpatched to an actual pv-index (index in permutation
167 ;;; vector) by MUTATE-SLOTS.
168 ;;;
169 ;;; The alist is in order, so the position of an entry in the alist
170 ;;; corresponds to the argument's position in the method lambda list.
171 ;;;
172 (defun optimize-slot-access (form env required-params param-slots)
173 (destructuring-bind (fn instance slot-name &optional value) form
174 (multiple-value-bind (access fallback-macro)
175 (ecase fn
176 (slot-value (values 'slot-value 'accessor-slot-value))
177 (slot-boundp (values 'slot-boundp 'accessor-slot-boundp))
178 (set-slot-value (values 'setf 'accessor-set-slot-value)))
179 (assert (constantp slot-name))
180 (let ((slot-name (eval slot-name))
181 (fallback-access `(,fallback-macro (optimized-marker ,instance)
182 ,@(cddr form))))
183 (multiple-value-bind (param class optimize-p)
184 (get-param/class-to-optimize instance required-params env
185 access slot-name)
186 (cond ((not optimize-p)
187 (when param
188 (check-inline-access-p class slot-name env))
189 fallback-access)
190 ((and (eq *boot-state* 'complete)
191 (classp class)
192 (member *the-class-structure-object*
193 (class-precedence-list class) :test #'eq))
194 (emit-structure-access access param class slot-name value))
195 ((check-inline-access-p class slot-name env)
196 (emit-inline-access access param class slot-name value
197 param-slots env))
198 (t
199 (emit-pv-access access param class slot-name value
200 param-slots fallback-access env))))))))
201
202 ;;;
203 ;;; Determine method parameter and its class for slot access
204 ;;; optimization. INSTANCE is the instance part of the form being
205 ;;; optimized. REQUIRED-PARAMS is a list of the names of the required
206 ;;; parameters of the method being optimized. ENV is the environment
207 ;;; in which the slot access occurs.
208 ;;;
209 ;;; SLOT-VALUE-ACCESS being one of the symbols SLOT-VALUE,
210 ;;; SLOT-BOUNDP, or SETF means the slot access is through one of these
211 ;;; operators. SLOT-NAME must be the name of the slot being accessed
212 ;;; in these cases. SLOT-VALUE-ACCESS NIL means the access is through
213 ;;; a reader/writer generic function.
214 ;;;
215 ;;; Values are either NIL or PARAM and CLASS. The NIL case means that
216 ;;; this access shouldn't or can't be optimized. Otherwise, PARAM is
217 ;;; the name of the method parameter through which the slot is
218 ;;; accessed and CLASS is its class or the name of its class.
219 ;;;
220 (defun get-param/class-to-optimize (instance required-params env
221 &optional slot-value-access slot-name)
222 (flet ((declared-class (param env)
223 (caddr (variable-declaration 'class param env))))
224 (let* ((param (method-parameter instance required-params env))
225 (class-name (when param (declared-class param env)))
226 class
227 optimize-p)
228 (when (and class-name (not (eq class-name t)))
229 (setq class (when (eq *boot-state* 'complete)
230 (let ((class (find-class class-name nil)))
231 (when (and class (class-finalized-p class))
232 class))))
233 (setq optimize-p
234 ;;
235 ;; When access is through a slot reader/writer, it's
236 ;; not easy to tell which slot that reads, which we
237 ;; need below, so just optimize it and let the PV
238 ;; machinery figure out what to do.
239 (or (null slot-value-access)
240 ;;
241 ;; Problem during bootstrapping PCL: some generic
242 ;; functions are not yet available when this function
243 ;; is called, esp. SLOT-ACCESSOR-STD-P which is used
244 ;; in DECIDE-OPTIMIZE-SLOT-P. Calling these
245 ;; functions results in an error that the funcallable
246 ;; instance function of these generic functions is
247 ;; not set.
248 (not (eq *boot-state* 'complete))
249 ;;
250 (decide-optimize-slot-p class-name slot-name
251 (ecase slot-value-access
252 (slot-value 'reader)
253 (slot-boundp 'boundp)
254 (setf 'writer))))))
255 (values param (or class class-name) optimize-p))))
256
257 ;;;
258 ;;; Return true if access to slot SLOT-NAME of class CLASS should use
259 ;;; the inline access method.
260 ;;;
261 ;;; Use inline slot access only if the class is known at compile time.
262 ;;; To overcome this restriction, we would need to compute slot
263 ;;; locations in the compile-time environment, that is, we would need
264 ;;; to duplicate COMPUTE-SLOTS or something. Also, we would have to
265 ;;; prevent methods on COMPUTE-SLOTS and maybe other methods that
266 ;;; influence slot location computation.
267 ;;;
268 (defun check-inline-access-p (class slot-name env)
269 (when (and *optimize-inline-slot-access-p*
270 (slot-declaration env 'inline class slot-name))
271 (let ((slotd nil))
272 (cond
273 ;;
274 ;; For now only for standard classes. If this
275 ;; is changed we need to get smart.
276 ((not (standard-class-p class))
277 (cant-optimize class _"The class is not a standard class"))
278 ;;
279 ((null (setq slotd (find-slot-definition class slot-name)))
280 (cant-optimize class _"The class doesn't contain a slot with name ~s"
281 slot-name))
282 ;;
283 ;; Class slots not implemented because it's difficult to
284 ;; back-patch the class slot cons cell into the code. It's
285 ;; anyway not important to optimize this.
286 ((consp (slot-definition-location slotd))
287 (cant-optimize class _"Slot ~s is a class slot" slot-name))
288 ;;
289 ;; Check for non-standard slot accessors, SLOT-VALUE-USING-CLASS.
290 ((not (optimize-slot-value-by-class-p class slot-name 'all))
291 (cant-optimize class _"There are non-standard accessors for slot ~s"
292 slot-name))
293 ;;
294 ;; Check if the accessed slot is at the same location in the
295 ;; class and all its subclasses.
296 ((not (slot-at-fixed-location-p class slot-name))
297 (cant-optimize class _"Slot ~s is not at the same location ~
298 in the class and all of its subclasses"
299 slot-name))
300 ;;
301 (t t)))))
302
303 (defun optimize-slot-value-by-class-p (class slot-name type)
304 (or (not (eq *boot-state* 'complete))
305 (let ((slotd (find-slot-definition class slot-name)))
306 (and slotd (slot-accessor-std-p slotd type)))))
307
308
309 ;;; ***************************
310 ;;; Inline Slot Access *******
311 ;;; ***************************
312
313 ;;;
314 ;;; Return a form for reading, setting, or boundp-testing slot
315 ;;; SLOT-NAME of a inline class CLASS.
316 ;;;
317 ;;; ENV is the enviroment in which the slot access occurs. It is used
318 ;;; for the declarations in it. ACCESS is one of the symbols
319 ;;; SLOT-VALUE, SETF, or SLOT-BOUNDP specifying the kind of slot
320 ;;; access to generate code for.
321 ;;;
322 ;;; PARAM-SLOTS is the usual alist of slots accessed through
323 ;;; parameters; see OPTIMIZE-SLOT-ACCESS.
324 ;;;
325 ;;; VALUE is the new-value form for the case of SETF SLOT-VALUE.
326 ;;;
327 (defun emit-inline-access (access param class slot-name value
328 param-slots env)
329 (let ((slots-variable (add-param-slot-entry param '(inline-access)
330 param-slots)))
331 (pushnew (class-name class) *inline-access*)
332 (ecase access
333 (slot-value
334 (let ((boundp (slot-declaration env 'slot-boundp class slot-name)))
335 `(inline-slot-value ,param ,class ,slot-name ,slots-variable
336 ,(not boundp))))
337 (setf
338 `(inline-set-slot-value ,class ,slot-name ,slots-variable ,value))
339 (slot-boundp
340 `(inline-slot-boundp ,class ,slot-name ,slots-variable)))))
341
342 ;;;
343 ;;; The following three macros implement slot access for the inline
344 ;;; slot access method.
345 ;;;
346
347 (defmacro inline-slot-value (param class slot-name slots-variable
348 check-bound-p)
349 (multiple-value-bind (read-form slot-type)
350 (inline-slot-read-form class slot-name slots-variable)
351 (if check-bound-p
352 `(the ,slot-type
353 (let ((.slot-value. ,read-form))
354 (if (eq .slot-value. +slot-unbound+)
355 (inline-slot-unbound ,param ',slot-name)
356 .slot-value.)))
357 `(the ,slot-type ,read-form))))
358
359 (defun inline-slot-unbound (instance slot-name)
360 (values (slot-unbound (class-of instance) instance slot-name)))
361
362 (defmacro inline-slot-boundp (class slot-name slots-variable)
363 (multiple-value-bind (read-form slot-type)
364 (inline-slot-read-form class slot-name slots-variable)
365 (declare (ignore slot-type))
366 `(not (eq ,read-form +slot-unbound+))))
367
368 (defmacro inline-set-slot-value (class slot-name slots-variable value-form)
369 (multiple-value-bind (read-form slot-type)
370 (inline-slot-read-form class slot-name slots-variable)
371 `(setf ,read-form (the ,slot-type ,value-form))))
372
373 ;;;
374 ;;; Return two values READ-FORM and SLOT-TYPE for reading slot
375 ;;; SLOT-NAME of an instance of a inline class CLASS. READ-FORM is a
376 ;;; form that can be used to read the value of the slot. SLOT-TYPE is
377 ;;; the type of the slot.
378 ;;;
379 ;;; SLOTS-VARIABLE is the name of a variable bound to the instance's
380 ;;; slot vector.
381 ;;;
382 (defun inline-slot-read-form (class slot-name slots-variable)
383 (let* ((slotd (find-slot-definition class slot-name))
384 (location (slot-definition-location slotd)))
385 (values (etypecase location
386 (fixnum
387 `(%svref ,slots-variable ,location)))
388 (slot-type class slot-name))))
389
390 ;;;
391 ;;; True if slot SLOT-NAME has the same location in CLASS and all of
392 ;;; its subclasses.
393 ;;;
394 (defun slot-at-fixed-location-p (class slot-name)
395 (labels ((location (class slot-name)
396 (let ((slot (find-slot-definition class slot-name)))
397 (slot-definition-location slot)))
398 (fixed-p (class slot-name location)
399 (loop for subclass in (class-direct-subclasses class)
400 as subclass-location = (location subclass slot-name)
401 always (and (eql location subclass-location)
402 (fixed-p subclass slot-name location)))))
403 (fixed-p class slot-name (location class slot-name))))
404
405
406 ;;; ********************************************************
407 ;;; Inline Slot Access Info on Classes and Methods ********
408 ;;; ********************************************************
409
410 (defun methods-using-inline-slot-access (class)
411 (let ((class (if (classp class) class (find-class class))))
412 (plist-value class 'inline-access)))
413
414 (defun method-info (method)
415 (plist-value method 'method-info))
416
417 (defun record-inline-access-info (method class-names method-info)
418 (when (eq *boot-state* 'complete)
419 (setf (plist-value method 'inline-access) class-names)
420 (setf (plist-value method 'method-info) method-info)
421 (loop for class-name in class-names
422 as class = (find-class class-name) do
423 (pushnew method (plist-value class 'inline-access)))))
424
425 (defun remove-inline-access-method (class method)
426 (let ((methods (methods-using-inline-slot-access class)))
427 (when methods
428 (setf (plist-value class 'inline-access)
429 (remove method methods)))))
430
431 (defun update-inline-access (class)
432 (let ((methods (loop for class in (class-precedence-list class)
433 append (methods-using-inline-slot-access class))))
434 (loop for method in methods
435 as defmethod-form = (reconstruct-defmethod-form method)
436 if defmethod-form do
437 (warn _"Auto-compiling method ~s." method)
438 (eval defmethod-form)
439 else
440 collect method into remaining-methods
441 finally
442 (setq methods remaining-methods))
443 (when methods
444 (warn 'method-recompilation-warning
445 :title _"Methods may need to be recompiled for the changed ~
446 class layout of"
447 :class class
448 :format-control "~{~% ~s~}"
449 :format-arguments (list methods)))))
450
451 (defun reconstruct-defmethod-form (method)
452 (let ((method-info (method-info method)))
453 (when method-info
454 (destructuring-bind (body lambda-list) method-info
455 (let ((method-name (generic-function-name
456 (method-generic-function method)))
457 (qualifiers (method-qualifiers method)))
458 `(defmethod ,method-name ,@qualifiers ,lambda-list
459 ,@body))))))
460
461
462 ;;; ************************
463 ;;; PV Slot Access ********
464 ;;; ************************
465
466 ;;;
467 ;;; Return a form for accessing slot SLOT-NAME of method parameter PARAM
468 ;;; using the pv indirection.
469 ;;;
470 ;;; ENV is the environment in which the slot access occurs. It is
471 ;;; used to find declarations in it. ACCESS is the type of access,
472 ;;; one of SLOT-VALUE, SETF, SLOT-BOUNDP. PARAM is the name of the
473 ;;; method parameter whose slot is accessed, and CLASS is the
474 ;;; parameter's class. VALUE is a form for the value part of (SETF
475 ;;; SLOT-VALUE). FALLBACK-ACCESS is a form for accessing the slot
476 ;;; when its pv-entry says the fast method can't be used.
477 ;;;
478 (defun emit-pv-access (access param class slot-name value
479 param-slots fallback-access env)
480 (let* ((pv-offset (list 'pv-offset -1))
481 (slots-variable (add-param-slot-entry param slot-name
482 param-slots pv-offset)))
483 (ecase access
484 (slot-value
485 (let ((boundp (slot-declaration env 'slot-boundp class slot-name)))
486 `(pv-slot-value ,class ,slot-name ,slots-variable ,pv-offset
487 ,(not boundp) t ,fallback-access)))
488 (setf
489 `(pv-set-slot-value ,class ,slot-name ,slots-variable
490 ,pv-offset ,value t ,fallback-access))
491 (slot-boundp
492 `(pv-slot-boundp ,class ,slot-name ,slots-variable
493 ,pv-offset ,fallback-access)))))
494
495 ;;;
496 ;;; The following three macros expand to code for SLOT-VALUE, (SETF
497 ;;; SLOT-VALUE), and SLOT-BOUNDP when pv optimization is used.
498 ;;;
499
500 (defmacro pv-slot-value (class slot-name slots-variable pv-offset
501 check-bound-p use-type-p fallback-access)
502 (multiple-value-bind (read-form predicate slot-type)
503 (pv-slot-read-form class slot-name slots-variable)
504 (let ((slot-type (if use-type-p slot-type t)))
505 (if check-bound-p
506 `(the ,slot-type
507 (locally
508 (declare #.*optimize-speed*)
509 (block nil
510 (let ((.location. (%svref .pv. ,pv-offset)))
511 (tagbody
512 (unless ,predicate
513 (go miss))
514 (let ((.slot-value. ,read-form))
515 (when (eq +slot-unbound+ .slot-value.)
516 (go miss))
517 (return .slot-value.))
518 miss
519 (return ,fallback-access))))))
520 `(the ,slot-type
521 (let ((.location. (%svref .pv. ,pv-offset)))
522 (declare #.*optimize-speed*)
523 (if ,predicate
524 ,read-form
525 ,fallback-access)))))))
526
527 (defmacro pv-slot-boundp (class slot-name slots-variable pv-offset
528 fallback-access)
529 (multiple-value-bind (read-form predicate slot-type)
530 (pv-slot-read-form class slot-name slots-variable)
531 (declare (ignore slot-type))
532 `(let ((.location. (%svref .pv. ,pv-offset)))
533 (declare #.*optimize-speed*)
534 (if ,predicate
535 (not (eq +slot-unbound+ ,read-form))
536 ,fallback-access))))
537
538 (defmacro pv-set-slot-value (class slot-name slots-variable
539 pv-offset value use-type-p fallback-access)
540 (multiple-value-bind (read-form predicate slot-type)
541 (pv-slot-read-form class slot-name slots-variable)
542 ;;
543 ;; Frob the fallback form because we put the value in a let-binding
544 ;; for checking its type.
545 (let ((fallback-access
546 (let ((copy (copy-seq fallback-access)))
547 (ecase (car fallback-access)
548 ((funcall setf)
549 (setf (third copy) '(optimized-marker .value.)))
550 (accessor-set-slot-value
551 (setf (fourth copy) '.value.)))
552 copy))
553 (slot-type (if use-type-p slot-type t)))
554 `(let ((.value. (the ,slot-type ,value)))
555 (let ((.location. (%svref .pv. ,pv-offset)))
556 (declare #.*optimize-speed*)
557 (if ,predicate
558 (setf ,read-form .value.)
559 ,fallback-access))))))
560
561 ;;;
562 ;;; Return three values READ-FORM, PREDICATE, SLOT-TYPE for access
563 ;;; to slot SLOT-NAME of class CLASS. SLOTS-VARIABLE is the name of
564 ;;; the local variable holding the instance's slot vector.
565 ;;;
566 ;;; READ-FORM is a form that can be used to read the value of the
567 ;;; slot.
568 ;;;
569 ;;; The returned PREDICATE is a form that can be used to check if a
570 ;;; permutation vector contains a valid entry for the slot access.
571 ;;; The variable .LOCATION. is assumed to hold the slot location that
572 ;;; was retrieved from the pv vector.
573 ;;;
574 ;;; SLOT-TYPE is the slot's type.
575 ;;;
576 (defun pv-slot-read-form (class slot-name slots-variable)
577 (let ((slot-type (slot-type class slot-name))
578 (likely-a-class-slot-p
579 (and (eq *boot-state* 'complete)
580 (constantp class)
581 (constantp slot-name)
582 (decide-class-slot-p (eval class) (eval slot-name)))))
583 (if likely-a-class-slot-p
584 (values '(cdr .location.)
585 '(consp .location.)
586 slot-type)
587 (values `(%svref ,slots-variable .location.)
588 '(fixnump .location.)
589 slot-type))))
590
591
592 ;;; ******************************
593 ;;; Structure Slot Access *******
594 ;;; ******************************
595
596 (defun emit-structure-access (access param class slot-name value)
597 (let* ((slotd (find-slot-definition class slot-name))
598 (accessor (slot-definition-defstruct-accessor-symbol slotd)))
599 (ecase access
600 (slot-value `(,accessor ,param))
601 (setf `(setf (,accessor ,param) ,value))
602 (slot-boundp t))))
603
604
605 ;;; ********************************************************
606 ;;; ******** Slot Reader/Writer Call Optimization ********
607 ;;; ********************************************************
608
609 ;;;
610 ;;; Optimize slot reader function calls in the same way as SLOT-VALUE.
611 ;;; ??? I think FORM can be (APPLY ...), which we could optimize here
612 ;;; as well, for completeness.
613 ;;;
614 (defun optimize-slot-reader (form required-parms param-slots env)
615 (when (and (eq *boot-state* 'complete)
616 *optimize-accessor-calls-p*
617 (or (not (consp (cadr form)))
618 (not (eq 'optimized-marker (caadr form)))))
619 (destructuring-bind (gf-name instance) form
620 (when (decide-optimize-accessor-p gf-name 'reader)
621 (multiple-value-bind (param class optimize-p)
622 (get-param/class-to-optimize instance required-parms env)
623 (when optimize-p
624 (setq form (optimize-slot-access/call
625 param-slots 'slot-value param class
626 gf-name nil env)))))))
627 form)
628
629 ;;;
630 ;;; Optimize setf's of slot readers. Called from WALK-METHOD-LAMBDA.
631 ;;;
632 ;;; FORM is (setf (GF OBJECT) VALUE), where GF is known to be a
633 ;;; generic function. REQUIRED-PARMS is a list of the required
634 ;;; parameters of the method in whose body FORM appears. PARAM-SLOTS
635 ;;; is an alist of pairs (PARM . PV-OFFSETS). PARM is one of the
636 ;;; required parameters.
637 ;;;
638 ;;; Value is either an optimized form that replaces FORM, or FORM.
639 ;;;
640 (defun optimize-slot-writer (form required-parms param-slots env)
641 (when (and (eq *boot-state* 'complete)
642 *optimize-accessor-calls-p*)
643 (destructuring-bind (setf (reader instance) value) form
644 (declare (ignore setf))
645 (let ((gf-name `(setf ,reader)))
646 (when (decide-optimize-accessor-p gf-name 'writer)
647 (multiple-value-bind (param class optimize-p)
648 (get-param/class-to-optimize instance required-parms env)
649 (when optimize-p
650 (setq form (optimize-slot-access/call
651 param-slots 'setf param class
652 gf-name value env))))))))
653 form)
654
655 ;;;
656 ;;; Generate code for reading/writing a slot using a slot accessor
657 ;;; generic function.
658 ;;;
659 ;;; ACCESS is one of SETF or SLOT-VALUE for writing or reading a slot.
660 ;;; PARAM is the method parameter through which the slot is accessed,
661 ;;; and CLASS is its class. GF-NAME is the name of the generic
662 ;;; reader or writer function called to access the slot. VALUE is the
663 ;;; value part for the SETF case. ENV is the environment in which the
664 ;;; access occurs.
665 ;;;
666 (defun optimize-slot-access/call (param-slots access param class
667 gf-name value env)
668 (let ((slot-name (check-inline-accessor-call-p access gf-name class env)))
669 (if slot-name
670 (emit-inline-access/call param-slots access param class
671 slot-name value env)
672 (emit-pv-access/call param-slots access param class gf-name
673 value env))))
674
675 ;;;
676 ;;; Check if a slot accessor call can/should be optimized to a inline
677 ;;; slot access. ACCESS is one of SLOT-VALUE or SETF for read or write
678 ;;; access. GF-NAME is the name of the generic function being called.
679 ;;; CLASS is the class of the instance being accessed. ENV is the
680 ;;; environment in which the access occurs. Value is true if the call
681 ;;; should and can be optimized.
682 ;;;
683 (defun check-inline-accessor-call-p (access gf-name class env)
684 (when *optimize-inline-slot-access-p*
685 ;;
686 ;; Check if CLASS is defined. If not, we can't use inline
687 ;; access because we won't be able to determine slot locations.
688 (unless (std-class-p class)
689 (let ((real-class (find-class class nil)))
690 (unless (std-class-p real-class)
691 (when (slot-declaration env 'inline class)
692 (cant-optimize class _"The class is not defined at compile time"))
693 (return-from check-inline-accessor-call-p nil))
694 (setq class real-class)))
695 ;;
696 (flet ((declared-inline (slot-name)
697 (slot-declaration env 'inline class slot-name)))
698 (multiple-value-bind (slot-names all-standard-accessors-p)
699 (slot-accessor-slot-names access gf-name class)
700 (cond ((and all-standard-accessors-p
701 slot-names
702 (null (cdr slot-names))
703 (check-inline-access-p class (car slot-names) env))
704 (car slot-names))
705 ((not (some #'declared-inline slot-names))
706 nil)
707 ((not all-standard-accessors-p)
708 (cant-optimize class _"~s has a method that is not a standard ~
709 slot accessor" gf-name))
710 (t
711 (cant-optimize class _"Methods of ~s access different slots"
712 gf-name)))))))
713
714 ;;;
715 ;;; Return two values SLOT-NAMES, ALL-STANDARD-P. SLOT-NAMES is a
716 ;;; list of the names of slots accessed by standard accessor methods
717 ;;; of type ACCESS (one of SETF/SLOT-VALUE for writers/readers)
718 ;;; applicable to CLASS. ALL-STANDARD-P true means all applicable
719 ;;; methods are standard accessor methods.
720 ;;;
721 (defun slot-accessor-slot-names (access gf-name class)
722 (loop with all-standard-p = t
723 for method in (compute-applicable-methods
724 (gdefinition gf-name)
725 (let ((proto (class-prototype class)))
726 (ecase access
727 (slot-value (list proto))
728 (setf (list t proto)))))
729 if (not (standard-accessor-method-p method)) do
730 (setq all-standard-p nil)
731 else
732 collect (slot-definition-name
733 (accessor-method-slot-definition method)) into slot-names
734 finally
735 (return (values slot-names all-standard-p))))
736
737 ;;;
738 ;;; Emit code for a pv slot accessor call.
739 ;;;
740 ;;; This generates entries ((READER <gf-name>) <pv-offet-form> ...) or
741 ;;; ((WRITER <gf-name>) <pv-offet-form> ...) in PARAM-SLOTS.
742 ;;;
743 (defun emit-pv-access/call (param-slots access param class gf-name value env)
744 (let* ((slot-name (ecase access
745 (slot-value `(reader ,gf-name))
746 (setf `(writer ,gf-name))))
747 (pv-offset (list 'pv-offset -1))
748 (slots-variable
749 (add-param-slot-entry param slot-name param-slots pv-offset)))
750 (ecase access
751 (slot-value
752 (let ((boundp (slot-declaration env 'slot-boundp class slot-name)))
753 `(pv-slot-value ,class ,slot-name ,slots-variable ,pv-offset
754 ,(not boundp) nil
755 (,gf-name (optimized-marker ,param)))))
756 (setf
757 `(pv-set-slot-value ,class ,slot-name ,slots-variable
758 ,pv-offset ,value nil
759 (funcall #',gf-name (optimized-marker ,value)
760 ,param))))))
761
762 ;;;
763 ;;; Emit code for a inline slot accessor call. This generates entries
764 ;;; ((INLINE-ACCESS)) in PARAM-SLOTS.
765 ;;;
766 (defun emit-inline-access/call (param-slots access param class
767 slot-name value env)
768 (let ((slots-variable (add-param-slot-entry param '(inline-access)
769 param-slots)))
770 (pushnew (class-name class) *inline-access*)
771 (ecase access
772 (slot-value
773 (let ((boundp (slot-declaration env 'slot-boundp class slot-name)))
774 `(inline-slot-value ,param ,class ,slot-name ,slots-variable
775 ,(not boundp))))
776 (setf
777 `(inline-set-slot-value ,class ,slot-name ,slots-variable ,value)))))
778
779 ;; end of method-slot-access-optimization.lisp

  ViewVC Help
Powered by ViewVC 1.1.5