/[cmucl]/src/pcl/combin.lisp
ViewVC logotype

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Wed May 28 10:41:47 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
Changes since 1.16: +113 -32 lines
	Support for inlineing of methods in effective methods.

	* src-emf/docs/cmu-user/extensions.tex (Inlineing Methods in
	Effective Methods): New subsection.

	* src-emf/pcl/combin.lisp:
	(method-function-name, make-direct-call, make-direct-calls)
	(call-method-list-methods): New functions.
	(memf-test-converter, memf-code-converter): Arrange for
	generating funcalls instead of invoke- macros.

	* src-emf/pcl/boot.lisp (*inline-methods-in-emfs*): New variable.
	(expand-defmethod): If set, arrange for inlineing fast method
	functions.

	* src-emf/pcl/pkg.lisp ("PCL"): Export flush-emf-cache.

	* src-emf/pcl/fngen.lisp (flush-emf-cache): New function.
1 ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26
27 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.17 2003/05/28 10:41:47 gerd Exp $")
29
30 (in-package "PCL")
31
32 ;;;
33 ;;; In the following:
34 ;;;
35 ;;; Something "callable" is either a function, a FAST-METHOD-CALL or
36 ;;; a METHOD-CALL instance, which can all be "invoked" by PCL.
37 ;;;
38 ;;; A generator for a "callable" is a function (closure) taking two
39 ;;; arguments METHOD-ALIST and WRAPPERS and returning a callable.
40 ;;;
41
42
43 ;;; *********************************************
44 ;;; The STANDARD method combination type *******
45 ;;; *********************************************
46 ;;;
47 ;;; This is coded by hand (rather than with DEFINE-METHOD-COMBINATION)
48 ;;; for bootstrapping and efficiency reasons. Note that the
49 ;;; definition of the find-method-combination-method appears in the
50 ;;; file defcombin.lisp, this is because EQL methods can't appear in
51 ;;; the bootstrap.
52 ;;;
53 ;;; This code must conform to the code in the file defcombin, look
54 ;;; there for more details.
55 ;;;
56
57 ;;;
58 ;;; When adding a method to COMPUTE-EFFECTIVE-METHOD for the standard
59 ;;; method combination, COMPUTE-EFFECTIVE-METHOD is called for
60 ;;; determining the effective method of COMPUTE-EFFECTIVE-METHOD.
61 ;;; That's a chicken and egg problem. It's solved in dfun.lisp by
62 ;;; always calling STANDARD-COMPUTE-EFFECTIVE-METHOD for the case of
63 ;;; COMPUTE-EFFECTIVE-METHOD.
64 ;;;
65 ;;; A similar problem occurs with all generic functions used to compute
66 ;;; an effective method. For example, if a method for METHOD-QUALIFIERS
67 ;;; is performed, the generic function METHOD-QUALIFIERS will be called,
68 ;;; and it's not ready for use.
69 ;;;
70 ;;; That's actually the well-known meta-circularity of PCL.
71 ;;;
72 ;;; Can we use an existing definition in the compiling PCL, if any,
73 ;;; until the effective method is ready?
74 ;;;
75 #+loadable-pcl
76 (defmethod compute-effective-method ((gf generic-function)
77 (combin standard-method-combination)
78 applicable-methods)
79 (standard-compute-effective-method gf combin applicable-methods))
80
81 #-loadable-pcl
82 (defun compute-effective-method (gf combin applicable-methods)
83 (standard-compute-effective-method gf combin applicable-methods))
84
85 (defun standard-compute-effective-method (gf combin applicable-methods)
86 (declare (ignore combin))
87 (let ((before ())
88 (primary ())
89 (after ())
90 (around ()))
91 (flet ((lose (method why)
92 (invalid-method-error
93 method
94 "~@<The method ~S ~A. ~
95 Standard method combination requires all methods to have one ~
96 of the single qualifiers ~s, ~s and ~s or to have no qualifier ~
97 at all.~@:>"
98 method why :around :before :after)))
99 (dolist (m applicable-methods)
100 (let ((qualifiers (if (listp m)
101 (early-method-qualifiers m)
102 (method-qualifiers m))))
103 (cond ((null qualifiers)
104 (push m primary))
105 ((cdr qualifiers)
106 (lose m "has more than one qualifier"))
107 ((eq (car qualifiers) :around)
108 (push m around))
109 ((eq (car qualifiers) :before)
110 (push m before))
111 ((eq (car qualifiers) :after)
112 (push m after))
113 (t
114 (lose m "has an illegal qualifier"))))))
115 (setq before (reverse before)
116 after (reverse after)
117 primary (reverse primary)
118 around (reverse around))
119 (cond ((null primary)
120 `(%no-primary-method ',gf .args.))
121 ((and (null before) (null after) (null around))
122 ;;
123 ;; By returning a single CALL-METHOD form here, we enable
124 ;; an important implementation-specific optimization, which
125 ;; uses fast-method functions directly for effective method
126 ;; functions. (Which is also the reason emfs have a
127 ;; lambda-list like fast method functionts.)
128 ;;
129 ;; This cannot be done if the gf requires keyword argument
130 ;; checking as in CLHS 7.6.5 because we can't tell in
131 ;; method functions if they are used as emfs only. If they
132 ;; are not used as emfs only, they should accept any keyword
133 ;; argumests, per CLHS 7.6.4, for instance.
134 (let ((call-method `(call-method ,(first primary) ,(rest primary))))
135 (if (emfs-must-check-applicable-keywords-p gf)
136 `(progn ,call-method)
137 call-method)))
138 (t
139 (let ((main-effective-method
140 (if (or before after)
141 `(multiple-value-prog1
142 (progn
143 ,(make-call-methods before)
144 (call-method ,(first primary) ,(rest primary)))
145 ,(make-call-methods (reverse after)))
146 `(call-method ,(first primary) ,(rest primary)))))
147 (if around
148 `(call-method ,(first around)
149 (,@(rest around)
150 (make-method ,main-effective-method)))
151 main-effective-method))))))
152
153 (defvar *invalid-method-error*
154 (lambda (&rest args)
155 (declare (ignore args))
156 (error
157 "~@<~s was called outside the dynamic scope ~
158 of a method combination function (inside the body of ~
159 ~s or a method on the generic function ~s).~@:>"
160 'invalid-method-error 'define-method-combination
161 'compute-effective-method)))
162
163 (defvar *method-combination-error*
164 (lambda (&rest args)
165 (declare (ignore args))
166 (error
167 "~@<~s was called outside the dynamic scope ~
168 of a method combination function (inside the body of ~
169 ~s or a method on the generic function ~s).~@:>"
170 'method-combination-error 'define-method-combination
171 'compute-effective-method)))
172
173 (defun invalid-method-error (&rest args)
174 (apply *invalid-method-error* args))
175
176 (defun method-combination-error (&rest args)
177 (apply *method-combination-error* args))
178
179 (defmacro call-method (&rest args)
180 (declare (ignore args))
181 `(error "~@<~S used outsize of a effective method form.~@:>" 'call-method))
182
183 (defmacro call-method-list (&rest calls)
184 `(progn ,@calls))
185
186 (defun make-call-methods (methods)
187 `(call-method-list
188 ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
189
190
191 ;;; ****************************************************
192 ;;; Translating effective method bodies to Code *******
193 ;;; ****************************************************
194
195 (defun get-callable (gf form method-alist wrappers)
196 (funcall (callable-generator gf form method-alist wrappers)
197 method-alist wrappers))
198
199 (defun callable-generator (gf form method-alist-p wrappers-p)
200 (if (eq 'call-method (car-safe form))
201 (callable-generator-for-call-method gf form)
202 (callable-generator-for-emf gf form method-alist-p wrappers-p)))
203
204 ;;;
205 ;;; If the effective method is just a call to CALL-METHOD, this opens
206 ;;; up the possibility of just using the method function of the method
207 ;;; as the effective method function.
208 ;;;
209 ;;; But we have to be careful. If that method function will ask for
210 ;;; the next methods we have to provide them. We do not look to see
211 ;;; if there are next methods, we look at whether the method function
212 ;;; asks about them. If it does, we must tell it whether there are
213 ;;; or aren't to prevent the leaky next methods bug.
214 ;;;
215 (defun callable-generator-for-call-method (gf form)
216 (let* ((cm-args (cdr form))
217 (fmf-p (and (or (not (eq *boot-state* 'complete))
218 (gf-fast-method-function-p gf))
219 (null (cddr cm-args))))
220 (method (car cm-args))
221 (cm-args1 (cdr cm-args)))
222 (lambda (method-alist wrappers)
223 (callable-for-call-method gf method cm-args1 fmf-p method-alist
224 wrappers))))
225
226 (defun callable-for-call-method (gf method cm-args fmf-p method-alist wrappers)
227 (cond ((null method)
228 nil)
229 ((if (listp method)
230 (eq (car method) :early-method)
231 (method-p method))
232 (get-method-callable method cm-args gf fmf-p method-alist wrappers))
233 ((eq 'make-method (car-safe method))
234 (get-callable gf (cadr method) method-alist wrappers))
235 (t
236 method)))
237
238 ;;;
239 ;;; Return a FAST-METHOD-CALL structure, a METHOD-CALL structure, or a
240 ;;; method function for calling METHOD.
241 ;;;
242 (defun get-method-callable (method cm-args gf fmf-p method-alist wrappers)
243 (multiple-value-bind (mf real-mf-p fmf pv-cell)
244 (get-method-function method method-alist wrappers)
245 (cond (fmf
246 (let* ((next-methods (car cm-args))
247 (next (callable-for-call-method gf (car next-methods)
248 (list* (cdr next-methods)
249 (cdr cm-args))
250 fmf-p method-alist wrappers))
251 (arg-info (method-function-get fmf :arg-info)))
252 (make-fast-method-call :function fmf
253 :pv-cell pv-cell
254 :next-method-call next
255 :arg-info arg-info)))
256 (real-mf-p
257 (make-method-call :function mf :call-method-args cm-args))
258 (t mf))))
259
260 (defun get-method-function (method method-alist wrappers)
261 (let ((fn (cadr (assoc method method-alist))))
262 (if fn
263 (values fn nil nil nil)
264 (multiple-value-bind (mf fmf)
265 (if (listp method)
266 (early-method-function method)
267 (values nil (method-fast-function method)))
268 (let ((pv-table (and fmf (method-function-pv-table fmf))))
269 (if (and fmf
270 (not (and pv-table (pv-table-computing-cache-p pv-table)))
271 (or (null pv-table) wrappers))
272 (let* ((pv-wrappers (when pv-table
273 (pv-wrappers-from-all-wrappers
274 pv-table wrappers)))
275 (pv-cell (when (and pv-table pv-wrappers)
276 (pv-table-lookup pv-table pv-wrappers))))
277 (values mf t fmf pv-cell))
278 (values
279 (or mf (if (listp method)
280 (setf (cadr method)
281 (method-function-from-fast-function fmf))
282 (method-function method)))
283 t nil nil)))))))
284
285
286 ;;;
287 ;;; Return a closure returning a FAST-METHOD-CALL instance for the
288 ;;; call of an effective method of generic function GF with body
289 ;;; BODY.
290 ;;;
291 (defun callable-generator-for-emf (gf body method-alist-p wrappers-p)
292 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
293 (get-generic-function-info gf)
294 (declare (ignore nkeys arg-info))
295 (let* ((name (generic-function-name* gf))
296 (fmc-info (cons nreq applyp))
297 (effective-method-lambda (make-effective-method-lambda gf body)))
298 (multiple-value-bind (cfunction constants)
299 (get-function1 effective-method-lambda
300 (lambda (form)
301 (memf-test-converter form gf method-alist-p
302 wrappers-p))
303 (lambda (form)
304 (memf-code-converter form gf metatypes applyp
305 method-alist-p wrappers-p))
306 (lambda (form)
307 (memf-constant-converter form gf)))
308 (lambda (method-alist wrappers)
309 (declare (special *applicable-methods*))
310 (multiple-value-bind (valid-keys keyargs-start)
311 (when (memq '.valid-keys. constants)
312 (compute-applicable-keywords gf *applicable-methods*))
313 (flet ((compute-constant (constant)
314 (if (consp constant)
315 (case (car constant)
316 (.meth.
317 (funcall (cdr constant) method-alist wrappers))
318 (.meth-list.
319 (mapcar (lambda (fn)
320 (funcall fn method-alist wrappers))
321 (cdr constant)))
322 (t constant))
323 (case constant
324 (.keyargs-start. keyargs-start)
325 (.valid-keys. valid-keys)
326 (t constant)))))
327 (let ((fn (apply cfunction
328 (mapcar #'compute-constant constants))))
329 (set-function-name fn `(effective-method ,name))
330 (make-fast-method-call :function fn :arg-info fmc-info)))))))))
331
332 ;;;
333 ;;; Return true if emfs of generic function GF must do keyword
334 ;;; argument checking with CHECK-APPLICABLE-KEYWORDS.
335 ;;;
336 ;;; We currently do this if the generic function type has &KEY, which
337 ;;; should be the case if the gf or any method has &KEY. It would be
338 ;;; possible to avoid the check if it also has &ALLOW-OTHER-KEYS, iff
339 ;;; method functions do checks of their own, which is ugly to do,
340 ;;; so we don't.
341 ;;;
342 (defun emfs-must-check-applicable-keywords-p (gf)
343 (let ((type (info function type (generic-function-name* gf))))
344 (and (kernel::function-type-p type)
345 (kernel::function-type-keyp type))))
346
347 ;;;
348 ;;; Compute which keyword args are valid in a call of generic function
349 ;;; GF with applicable methods METHODS. See also CLHS 7.6.5.
350 ;;;
351 ;;; First value is either a list of valid keywords or T meaning all
352 ;;; keys are valid. Second value is the number of optional arguments
353 ;;; that GF takes. This number is used as an offset in the supplied
354 ;;; args .DFUN-REST-ARG. in CHECK-APPLICABLE-KEYWORDS.
355 ;;;
356 (defun compute-applicable-keywords (gf methods)
357 (let ((any-keyp nil))
358 (flet ((analyze (lambda-list)
359 (multiple-value-bind (nreq nopt keyp restp allowp keys)
360 (analyze-lambda-list lambda-list)
361 (declare (ignore nreq restp))
362 (when keyp
363 (setq any-keyp t))
364 (values nopt allowp keys))))
365 (multiple-value-bind (nopt allowp keys)
366 (analyze (generic-function-lambda-list gf))
367 (if allowp
368 (setq keys t)
369 (dolist (method methods)
370 (multiple-value-bind (n allowp method-keys)
371 (analyze (method-lambda-list* method))
372 (declare (ignore n))
373 (if allowp
374 (return (setq keys t))
375 (setq keys (union method-keys keys))))))
376 ;;
377 ;; It shouldn't happen thet neither the gf nor any method has
378 ;; &KEY, when this method is called. Let's handle the case
379 ;; anyway, just for generality.
380 (values (if any-keyp keys t) nopt)))))
381
382 ;;;
383 ;;; Check ARGS for invalid keyword arguments, beginning at position
384 ;;; START in ARGS. VALID-KEYS is a list of valid keywords. VALID-KEYS
385 ;;; being T means all keys are valid.
386 ;;;
387 (defun check-applicable-keywords (args start valid-keys)
388 (let ((allow-other-keys-seen nil)
389 (allow-other-keys nil)
390 (args (nthcdr start args)))
391 (collect ((invalid))
392 (loop
393 (when (null args)
394 (when (and (invalid) (not allow-other-keys))
395 (simple-program-error
396 "~@<Invalid keyword argument~p ~{~s~^, ~}. ~
397 Valid keywords are: ~{~s~^, ~}.~@:>"
398 (length (invalid))
399 (invalid)
400 valid-keys))
401 (return))
402 (let ((key (pop args)))
403 (cond ((not (symbolp key))
404 (invalid-keyword-argument key))
405 ((null args)
406 (odd-number-of-keyword-arguments))
407 ((eq key :allow-other-keys)
408 (unless allow-other-keys-seen
409 (setq allow-other-keys-seen t
410 allow-other-keys (car args))))
411 ((eq t valid-keys))
412 ((not (memq key valid-keys))
413 (invalid key))))
414 (pop args)))))
415
416 (defun odd-number-of-keyword-arguments ()
417 (simple-program-error "Odd number of keyword arguments."))
418
419 (defun invalid-keyword-argument (key)
420 (simple-program-error "Invalid keyword argument ~s" key))
421
422 ;;;
423 ;;; Return a lambda-form for an effective method of generic function
424 ;;; GF with body BODY.
425 ;;;
426 (defun make-effective-method-lambda (gf body)
427 (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
428 (get-generic-function-info gf)
429 (declare (ignore nreq nkeys arg-info))
430 ;;
431 ;; Note that emfs use the same lambda-lists as fast method
432 ;; functions, although they don't need all the arguments that a
433 ;; fast method function needs, because this makes it possible to
434 ;; use fast method functions directly as emfs. This is achieved
435 ;; by returning a single CALL-METHOD form from the method
436 ;; combination.
437 (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
438 (check-applicable-keywords
439 (when (and applyp (emfs-must-check-applicable-keywords-p gf))
440 '((check-applicable-keywords))))
441 (error-p (eq (first body) '%no-primary-method))
442 (mc-args-p
443 (when (eq *boot-state* 'complete)
444 ;; Otherwise the METHOD-COMBINATION slot is not bound.
445 (let ((combin (generic-function-method-combination gf)))
446 (and (long-method-combination-p combin)
447 (long-method-combination-args-lambda-list combin))))))
448 (cond (error-p
449 `(lambda (.pv-cell. .next-method-call. &rest .args.)
450 (declare (ignore .pv-cell. .next-method-call.))
451 ,body))
452 (mc-args-p
453 (let* ((required (dfun-arg-symbol-list metatypes))
454 (gf-args (if applyp
455 `(list* ,@required .dfun-rest-arg.)
456 `(list ,@required))))
457 `(lambda ,ll
458 (declare (ignore .pv-cell. .next-method-call.))
459 (let ((.gf-args. ,gf-args))
460 (declare (ignorable .gf-args.))
461 ,@check-applicable-keywords
462 ,body))))
463 (t
464 `(lambda ,ll
465 (declare (ignore .pv-cell. .next-method-call.))
466 ,@check-applicable-keywords
467 ,body))))))
468
469 ;;;
470 ;;; Return a method function name of METHOD. If FAST-FUNCTION
471 ;;; is true, return the fast method function name, otherwise
472 ;;; return the slow method function name.
473 ;;;
474 (defun method-function-name (method &optional (fast-function t))
475 (let ((name (nth-value 2 (parse-method-or-spec method))))
476 (if fast-function
477 (cons 'fast-method (cdr name))
478 name)))
479
480 ;;;
481 ;;; Return a form for calling METHOD's fast function. METATYPES is a
482 ;;; list of metatypes, whose length is used to figure out the names of
483 ;;; required emf parameters. APPLY? true means the method has a &rest
484 ;;; arg. CALLABLE-VAR is the name of a closed-over variable
485 ;;; containing a FAST-METHOD-CALL instance corresponding to the
486 ;;; method invocation.
487 ;;;
488 (defun make-direct-call (method metatypes rest? callable-var)
489 (let* ((fn-name (method-function-name method))
490 (fn `(the function #',fn-name))
491 (cell `(fast-method-call-pv-cell ,callable-var))
492 (next `(fast-method-call-next-method-call ,callable-var))
493 (req (dfun-arg-symbol-list metatypes)))
494 (assert (fboundp fn-name))
495 `(funcall ,fn ,cell ,next ,@req ,@(when rest? `(.dfun-rest-arg.)))))
496
497 ;;;
498 ;;; Return a form for successive calls to the fast functions of
499 ;;; the methods in METHODS. LIST-VAR is the name of a
500 ;;; variable containing a list of FAST-METHOD-CALL structures
501 ;;; corresponding to the method function calls.
502 ;;;
503 (defun make-direct-calls (methods metatypes apply? list-var)
504 (collect ((calls))
505 (dolist (method methods)
506 (calls `(let ((.call. (pop .list.)))
507 ,(make-direct-call method metatypes apply? '.call.))))
508 `(let ((.list. ,list-var))
509 (declare (ignorable .list.))
510 ,@(calls))))
511
512 ;;;
513 ;;; Return the list of methods from a CALL-METHOD-LIST form.
514 ;;;
515 (defun call-method-list-methods (call-method-list)
516 (mapcar (lambda (call-method) (cadr call-method))
517 (cdr call-method-list)))
518
519 ;;;
520 ;;; Compute a key from FORM. This function is called via the
521 ;;; GET-FUNCTION mechanism on forms of an emf lambda. Values returned
522 ;;; that are not EQ to FORM are considered keys. All keys are
523 ;;; collected and serve GET-FUNCTION as a key in its table of already
524 ;;; computed functions. That is, if two emf lambdas produce the same
525 ;;; key, a previously compiled function can be used.
526 ;;;
527 (defun memf-test-converter (form gf method-alist-p wrappers-p)
528 (case (car-safe form)
529 ;;
530 (call-method
531 (case (get-method-call-type gf form method-alist-p wrappers-p)
532 (fast-method-call
533 (let ((method (cadr form)))
534 (if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*)
535 (method-function-name method)
536 '.fast-call-method.)))
537 (t '.call-method.)))
538 ;;
539 (call-method-list
540 (case (get-method-list-call-type gf form method-alist-p wrappers-p)
541 (fast-method-call
542 (if (and (eq *boot-state* 'complete) *inline-methods-in-emfs*)
543 (mapcar #'method-function-name (call-method-list-methods form))
544 '.fast-call-method-list.))
545 (t '.call-method-list.)))
546 ;;
547 (check-applicable-keywords
548 'check-applicable-keywords)
549 (t
550 (default-test-converter form))))
551
552 ;;;
553 ;;; This function is called via the GET-FUNCTION mechanism on forms of
554 ;;; an emf lambda. First value returned replaces FORM in the emf
555 ;;; lambda. Second value is a list of variable names that become
556 ;;; closure variables.
557 ;;;
558 (defun memf-code-converter (form gf metatypes applyp method-alist-p
559 wrappers-p)
560 (case (car-safe form)
561 ;;
562 ;; (CALL-METHOD <method-object> &optional <next-methods>)
563 (call-method
564 (let ((method (cadr form))
565 (callable-var (gensym))
566 (call-type (get-method-call-type gf form method-alist-p
567 wrappers-p)))
568 (if (and (eq call-type 'fast-method-call)
569 (eq *boot-state* 'complete)
570 *inline-methods-in-emfs*)
571 (values (make-direct-call method metatypes applyp callable-var)
572 (list callable-var))
573 (values (make-emf-call metatypes applyp callable-var call-type)
574 (list callable-var)))))
575 ;;
576 ;; (CALL-METHOD-LIST <call-method-form>*)
577 ;; where each CALL-METHOD form is (CALL-METHOD <method>)
578 (call-method-list
579 (let ((list-var (gensym))
580 (call-type (get-method-list-call-type gf form method-alist-p
581 wrappers-p)))
582 (if (and (eq call-type 'fast-method-call)
583 (eq *boot-state* 'complete)
584 *inline-methods-in-emfs*)
585 (let ((methods (call-method-list-methods form)))
586 (values (make-direct-calls methods metatypes applyp list-var)
587 (list list-var)))
588 (values `(dolist (.tem. ,list-var)
589 ,(make-emf-call metatypes applyp '.tem. call-type))
590 (list list-var)))))
591 ;;
592 (check-applicable-keywords
593 (values `(check-applicable-keywords .dfun-rest-arg.
594 .keyargs-start. .valid-keys.)
595 '(.keyargs-start. .valid-keys.)))
596 (t
597 (default-code-converter form))))
598
599 (defun memf-constant-converter (form gf)
600 (case (car-safe form)
601 (call-method
602 (list (cons '.meth.
603 (callable-generator-for-call-method gf form))))
604 (call-method-list
605 (list (cons '.meth-list.
606 (mapcar (lambda (form)
607 (callable-generator-for-call-method gf form))
608 (cdr form)))))
609 (check-applicable-keywords
610 '(.keyargs-start. .valid-keys.))
611 (t
612 (default-constant-converter form))))
613
614 (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
615 (if (every (lambda (form)
616 (eq 'fast-method-call
617 (get-method-call-type gf form method-alist-p wrappers-p)))
618 (cdr form))
619 'fast-method-call
620 t))
621
622 (defun get-method-call-type (gf form method-alist-p wrappers-p)
623 (if (eq 'call-method (car-safe form))
624 (destructuring-bind (method &rest cm-args) (cdr form)
625 (declare (ignore cm-args))
626 (when method
627 (if (if (listp method)
628 (eq (car method) :early-method)
629 (method-p method))
630 (if method-alist-p
631 t
632 (multiple-value-bind (mf fmf)
633 (if (listp method)
634 (early-method-function method)
635 (values nil (method-fast-function method)))
636 (declare (ignore mf))
637 (let ((pv-table (and fmf (method-function-pv-table fmf))))
638 (if (and fmf (or (null pv-table) wrappers-p))
639 'fast-method-call
640 'method-call))))
641 (if (eq 'make-method (car-safe method))
642 (get-method-call-type gf (cadr method) method-alist-p
643 wrappers-p)
644 (type-of method)))))
645 'fast-method-call))
646
647
648 ;;; **************************************
649 ;;; Generating Callables for EMFs *******
650 ;;; **************************************
651
652 ;;;
653 ;;; Turned off until problems with method tracing caused by it are
654 ;;; solved (reason unknown). Will be needed once inlining of methods
655 ;;; in effective methods and inlining of effective method in callers
656 ;;; gets accute.
657 ;;;
658 (defvar *named-emfs-p* nil)
659
660 ;;;
661 ;;; Return a callable object for an emf of generic function GF, with
662 ;;; applicable methods METHODS. GENERATOR is a function returned from
663 ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and
664 ;;; WRAPPERS to obtain the actual callable.
665 ;;;
666 (defvar *applicable-methods*)
667
668 (defun make-callable (gf methods generator method-alist wrappers)
669 (let* ((*applicable-methods* methods)
670 (callable (function-funcall generator method-alist wrappers)))
671 (when *named-emfs-p*
672 (let ((fn (etypecase callable
673 (fast-method-call (fast-method-call-function callable))
674 (method-call (method-call-function callable))
675 (function callable))))
676 (setf (fdefinition (make-emf-name gf methods)) fn)))
677 callable))
678
679 ;;;
680 ;;; Return a name for an effective method of generic function GF,
681 ;;; composed of applicable methods METHODS.
682 ;;;
683 ;;; In general, the name cannot be based on the methods alone, because
684 ;;; that doesn't take method combination arguments into account.
685 ;;;
686 ;;; It is possible to do better for the standard method combination,
687 ;;; though. The current name format is
688 ;;;
689 ;;; (EFFECTIVE-METHOD gf-name around-methods before-methods
690 ;;; primary-method after-methods)
691 ;;;
692 ;;; where each method is a list (METHOD qualifiers specializers).
693 ;;;
694 (defvar *emf-name-table* (make-hash-table :test 'equal))
695
696 (defun make-emf-name (gf methods)
697 (let* ((early-p (early-gf-p gf))
698 (gf-name (generic-function-name* gf))
699 (emf-name
700 (if (or early-p
701 (eq (generic-function-method-combination gf)
702 *standard-method-combination*))
703 (let (primary around before after)
704 (dolist (m methods)
705 (let ((qual (if early-p
706 (early-method-qualifiers m)
707 (method-qualifiers m)))
708 (specl (if early-p
709 (early-method-specializers m)
710 (unparse-specializers
711 (method-specializers m)))))
712 (case (car-safe qual)
713 (:around (push `(method :around ,specl) around))
714 (:before (push `(method :before ,specl) before))
715 (:after (push `(method :after ,specl) after))
716 (t (push `(method ,specl) primary)))))
717 `(effective-method ,gf-name
718 ,@(nreverse around)
719 ,@(nreverse before)
720 ,@(list (last primary))
721 ,@after))
722 `(effective-method ,gf-name ,(gensym)))))
723 (or (gethash emf-name *emf-name-table*)
724 (setf (gethash emf-name *emf-name-table*) emf-name))))
725
726 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5