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

Contents of /src/pcl/combin.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13.2.1 - (hide annotations)
Sun Mar 9 12:47:20 2003 UTC (11 years, 1 month ago) by gerd
Branch: cold-pcl
Changes since 1.13: +434 -379 lines
*** empty log message ***
1 wlott 1.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 pw 1.9
27 dtc 1.8 (ext:file-comment
28 gerd 1.13.2.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/combin.lisp,v 1.13.2.1 2003/03/09 12:47:20 gerd Exp $")
29 ram 1.5
30 gerd 1.13.2.1 (in-package "PCL")
31 ram 1.5
32 gerd 1.13.2.1 ;;;
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 wlott 1.1
57 gerd 1.13.2.1 ;;;
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 ram 1.5
85 gerd 1.13.2.1 (defun standard-compute-effective-method (gf combin applicable-methods)
86 ram 1.5 (declare (ignore combin))
87     (let ((before ())
88     (primary ())
89     (after ())
90     (around ()))
91 pmai 1.10 (flet ((lose (method why)
92     (invalid-method-error
93     method
94 gerd 1.13.2.1 "~@<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 pmai 1.10 (dolist (m applicable-methods)
100     (let ((qualifiers (if (listp m)
101     (early-method-qualifiers m)
102     (method-qualifiers m))))
103 gerd 1.13.2.1 (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 ram 1.5 (setq before (reverse before)
116     after (reverse after)
117     primary (reverse primary)
118     around (reverse around))
119     (cond ((null primary)
120 gerd 1.13.2.1 `(%no-primary-method ',gf .args.))
121 ram 1.5 ((and (null before) (null after) (null around))
122     ;;
123 gerd 1.13.2.1 ;; By returning a single CALL-METHOD form here, we enable an
124 pmai 1.10 ;; important implementation-specific optimization.
125 ram 1.5 `(call-method ,(first primary) ,(rest primary)))
126     (t
127     (let ((main-effective-method
128     (if (or before after)
129     `(multiple-value-prog1
130 pmai 1.10 (progn
131     ,(make-call-methods before)
132     (call-method ,(first primary) ,(rest primary)))
133 ram 1.5 ,(make-call-methods (reverse after)))
134     `(call-method ,(first primary) ,(rest primary)))))
135     (if around
136     `(call-method ,(first around)
137 pmai 1.10 (,@(rest around)
138 gerd 1.13.2.1 (make-method ,main-effective-method)))
139 ram 1.5 main-effective-method))))))
140    
141 wlott 1.1 (defvar *invalid-method-error*
142 pmai 1.11 (lambda (&rest args)
143     (declare (ignore args))
144     (error
145 gerd 1.13.2.1 "~@<~s was called outside the dynamic scope ~
146     of a method combination function (inside the body of ~
147     ~s or a method on the generic function ~s).~@:>"
148     'invalid-method-error 'define-method-combination
149     'compute-effective-method)))
150 wlott 1.1
151     (defvar *method-combination-error*
152 pmai 1.11 (lambda (&rest args)
153     (declare (ignore args))
154     (error
155 gerd 1.13.2.1 "~@<~s was called outside the dynamic scope ~
156     of a method combination function (inside the body of ~
157     ~s or a method on the generic function ~s).~@:>"
158     'method-combination-error 'define-method-combination
159     'compute-effective-method)))
160 wlott 1.1
161     (defun invalid-method-error (&rest args)
162     (apply *invalid-method-error* args))
163    
164     (defun method-combination-error (&rest args)
165     (apply *method-combination-error* args))
166    
167 gerd 1.13.2.1 (defmacro call-method (&rest args)
168     (declare (ignore args))
169     `(error "~@<~S used outsize of a effective method form.~@:>" 'call-method))
170    
171     (defmacro call-method-list (&rest calls)
172     `(progn ,@calls))
173    
174     (defun make-call-methods (methods)
175     `(call-method-list
176     ,@(mapcar (lambda (method) `(call-method ,method ())) methods)))
177    
178    
179     ;;; ****************************************************
180     ;;; Translating effective method bodies to Code *******
181     ;;; ****************************************************
182    
183     (defun get-callable (gf form method-alist wrappers)
184     (funcall (callable-generator gf form method-alist wrappers)
185     method-alist wrappers))
186    
187     (defun callable-generator (gf form method-alist-p wrappers-p)
188     (if (eq 'call-method (car-safe form))
189     (callable-generator-for-call-method gf form)
190     (callable-generator-for-emf gf form method-alist-p wrappers-p)))
191    
192     ;;;
193     ;;; If the effective method is just a call to CALL-METHOD, this opens
194     ;;; up the possibility of just using the method function of the method
195     ;;; as the effective method function.
196     ;;;
197     ;;; But we have to be careful. If that method function will ask for
198     ;;; the next methods we have to provide them. We do not look to see
199     ;;; if there are next methods, we look at whether the method function
200     ;;; asks about them. If it does, we must tell it whether there are
201     ;;; or aren't to prevent the leaky next methods bug.
202     ;;;
203     (defun callable-generator-for-call-method (gf form)
204     (let* ((cm-args (cdr form))
205     (fmf-p (and (or (not (eq *boot-state* 'complete))
206     (gf-fast-method-function-p gf))
207     (null (cddr cm-args))))
208     (method (car cm-args))
209     (cm-args1 (cdr cm-args)))
210     (lambda (method-alist wrappers)
211     (callable-for-call-method gf method cm-args1 fmf-p method-alist
212     wrappers))))
213    
214     (defun callable-for-call-method (gf method cm-args fmf-p method-alist wrappers)
215     (cond ((null method)
216     nil)
217     ((if (listp method)
218     (eq (car method) :early-method)
219     (method-p method))
220     (get-method-callable method cm-args gf fmf-p method-alist wrappers))
221     ((eq 'make-method (car-safe method))
222     (get-callable gf (cadr method) method-alist wrappers))
223     (t
224     method)))
225    
226     ;;;
227     ;;; Return a FAST-METHOD-CALL structure, a METHOD-CALL structure, or a
228     ;;; method function for calling METHOD.
229     ;;;
230     (defun get-method-callable (method cm-args gf fmf-p method-alist wrappers)
231     (multiple-value-bind (mf real-mf-p fmf pv-cell)
232     (get-method-function method method-alist wrappers)
233     (cond (fmf
234     (let* ((next-methods (car cm-args))
235     (next (callable-for-call-method gf (car next-methods)
236     (list* (cdr next-methods)
237     (cdr cm-args))
238     fmf-p method-alist wrappers))
239     (arg-info (method-function-get fmf :arg-info)))
240     (make-fast-method-call :function fmf
241     :pv-cell pv-cell
242     :next-method-call next
243     :arg-info arg-info)))
244     (real-mf-p
245     (make-method-call :function mf :call-method-args cm-args))
246     (t mf))))
247    
248     (defun get-method-function (method method-alist wrappers)
249     (let ((fn (cadr (assoc method method-alist))))
250     (if fn
251     (values fn nil nil nil)
252     (multiple-value-bind (mf fmf)
253     (if (listp method)
254     (early-method-function method)
255     (values nil (method-fast-function method)))
256     (let ((pv-table (and fmf (method-function-pv-table fmf))))
257     (if (and fmf
258     (not (and pv-table (pv-table-computing-cache-p pv-table)))
259     (or (null pv-table) wrappers))
260     (let* ((pv-wrappers (when pv-table
261     (pv-wrappers-from-all-wrappers
262     pv-table wrappers)))
263     (pv-cell (when (and pv-table pv-wrappers)
264     (pv-table-lookup pv-table pv-wrappers))))
265     (values mf t fmf pv-cell))
266     (values
267     (or mf (if (listp method)
268     (setf (cadr method)
269     (method-function-from-fast-function fmf))
270     (method-function method)))
271     t nil nil)))))))
272    
273    
274     ;;;
275     ;;; Return a closure returning a FAST-METHOD-CALL instance for the
276     ;;; call of the effective method of generic function GF with body
277     ;;; BODY.
278     ;;;
279     (defun callable-generator-for-emf (gf body method-alist-p wrappers-p)
280     (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
281     (get-generic-function-info gf)
282     (declare (ignore nkeys arg-info))
283     (let* ((name (if (early-gf-p gf)
284     (early-gf-name gf)
285     (generic-function-name gf)))
286     (arg-info (cons nreq applyp))
287     (effective-method-lambda (make-effective-method-lambda gf body)))
288     (multiple-value-bind (cfunction constants)
289     (get-function1 effective-method-lambda
290     (lambda (form)
291     (memf-test-converter form gf method-alist-p
292     wrappers-p))
293     (lambda (form)
294     (memf-code-converter form gf metatypes applyp
295     method-alist-p wrappers-p))
296     (lambda (form)
297     (memf-constant-converter form gf)))
298     (lambda (method-alist wrappers)
299     (let* ((constants
300     (mapcar (lambda (constant)
301     (case (car-safe constant)
302     (.meth.
303     (funcall (cdr constant) method-alist wrappers))
304     (.meth-list.
305     (mapcar (lambda (fn)
306     (funcall fn method-alist wrappers))
307     (cdr constant)))
308     (t constant)))
309     constants))
310     (function (set-function-name (apply cfunction constants)
311     `(effective-method ,name))))
312     (make-fast-method-call :function function
313     :arg-info arg-info)))))))
314    
315     ;;;
316     ;;; Return a lambda-form for an effective method of generic function
317     ;;; GF with body BODY.
318     ;;;
319     (defun make-effective-method-lambda (gf body)
320     (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
321     (get-generic-function-info gf)
322     (declare (ignore nreq nkeys arg-info))
323     (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
324     (error-p (eq (first body) '%no-primary-method))
325     (mc-args-p
326     (when (eq *boot-state* 'complete)
327     ;; Otherwise the METHOD-COMBINATION slot is not bound.
328     (let ((combin (generic-function-method-combination gf)))
329     (and (long-method-combination-p combin)
330     (long-method-combination-args-lambda-list combin))))))
331     (cond (error-p
332     `(lambda (.pv-cell. .next-method-call. &rest .args.)
333     (declare (ignore .pv-cell. .next-method-call.))
334     ,body))
335     (mc-args-p
336     (let* ((required (dfun-arg-symbol-list metatypes))
337     (gf-args (if applyp
338     `(list* ,@required .dfun-rest-arg.)
339     `(list ,@required))))
340     `(lambda ,ll
341     (declare (ignore .pv-cell. .next-method-call.))
342     (let ((.gf-args. ,gf-args))
343     (declare (ignorable .gf-args.))
344     ,body))))
345     (t
346     `(lambda ,ll
347     (declare (ignore .pv-cell. .next-method-call.))
348     ,body))))))
349    
350     (defun memf-test-converter (form gf method-alist-p wrappers-p)
351     (case (car-safe form)
352     (call-method
353     (case (get-method-call-type gf form method-alist-p wrappers-p)
354     (fast-method-call '.fast-call-method.)
355     (t '.call-method.)))
356     (call-method-list
357     (case (get-method-list-call-type gf form method-alist-p wrappers-p)
358     (fast-method-call '.fast-call-method-list.)
359     (t '.call-method-list.)))
360     (t
361     (default-test-converter form))))
362    
363     (defun memf-code-converter (form gf metatypes applyp method-alist-p
364     wrappers-p)
365     (case (car-safe form)
366     (call-method
367     (let ((gensym (gensym "MEMF")))
368     (values (make-emf-call metatypes applyp gensym
369     (get-method-call-type gf form method-alist-p
370     wrappers-p))
371     (list gensym))))
372     (call-method-list
373     (let ((gensym (gensym "MEMF"))
374     (type (get-method-list-call-type gf form method-alist-p
375     wrappers-p)))
376     (values `(dolist (emf ,gensym nil)
377     ,(make-emf-call metatypes applyp 'emf type))
378     (list gensym))))
379     (t
380     (default-code-converter form))))
381    
382     (defun memf-constant-converter (form gf)
383     (case (car-safe form)
384     (call-method
385     (list (cons '.meth.
386     (callable-generator-for-call-method gf form))))
387     (call-method-list
388     (list (cons '.meth-list.
389     (mapcar (lambda (form)
390     (callable-generator-for-call-method gf form))
391     (cdr form)))))
392     (t
393     (default-constant-converter form))))
394    
395     (defun get-method-list-call-type (gf form method-alist-p wrappers-p)
396     (if (every (lambda (form)
397     (eq 'fast-method-call
398     (get-method-call-type gf form method-alist-p wrappers-p)))
399     (cdr form))
400     'fast-method-call
401     t))
402    
403     (defun get-method-call-type (gf form method-alist-p wrappers-p)
404     (if (eq 'call-method (car-safe form))
405     (destructuring-bind (method &rest cm-args) (cdr form)
406     (declare (ignore cm-args))
407     (when method
408     (if (if (listp method)
409     (eq (car method) :early-method)
410     (method-p method))
411     (if method-alist-p
412     t
413     (multiple-value-bind (mf fmf)
414     (if (listp method)
415     (early-method-function method)
416     (values nil (method-fast-function method)))
417     (declare (ignore mf))
418     (let ((pv-table (and fmf (method-function-pv-table fmf))))
419     (if (and fmf (or (null pv-table) wrappers-p))
420     'fast-method-call
421     'method-call))))
422     (if (eq 'make-method (car-safe method))
423     (get-method-call-type gf (cadr method) method-alist-p
424     wrappers-p)
425     (type-of method)))))
426     'fast-method-call))
427    
428    
429     ;;; **************************************
430     ;;; Generating Callables for EMFs *******
431     ;;; **************************************
432    
433     ;;;
434     ;;; Turned off until problems with method tracing caused by it are
435     ;;; solved (reason unknown). Will be needed once inlining of methods
436     ;;; in effective methods and inlining of effective method in callers
437     ;;; gets accute.
438     ;;;
439     (defvar *named-emfs-p* nil)
440    
441     ;;;
442     ;;; Return a callable object for an emf of generic function GF, with
443     ;;; applicable methods METHODS. GENERATOR is a function returned from
444     ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and
445     ;;; WRAPPERS to obtain the actual callable.
446     ;;;
447     (defun make-callable (gf methods generator method-alist wrappers)
448     (let ((callable (function-funcall generator method-alist wrappers)))
449     (set-emf-name gf methods callable)))
450    
451     ;;;
452     ;;; When *NAME-EMFS-P* is true, give the effective method represented
453     ;;; by CALLABLE a suitable global name of the form (EFFECTIVE-METHOD
454     ;;; ...). GF is the generic function the effective method is for, and
455     ;;; METHODS is the list of applicable methods.
456     ;;;
457     (defun set-emf-name (gf methods callable)
458     (when *named-emfs-p*
459     (let ((function (typecase callable
460     (fast-method-call (fast-method-call-function callable))
461     (method-call (method-call-function callable))
462     (t callable)))
463     (name (make-emf-name gf methods)))
464     (setf (fdefinition name) function)
465     (set-function-name function name)))
466     callable)
467    
468     ;;;
469     ;;; Return a name for an effective method of generic function GF,
470     ;;; composed of applicable methods METHODS.
471     ;;;
472     ;;; In general, the name cannot be based on the methods alone, because
473     ;;; that doesn't take method combination arguments into account.
474     ;;;
475     ;;; It is possible to do better for the standard method combination,
476     ;;; though. The current name format is
477     ;;;
478     ;;; (EFFECTIVE-METHOD gf-name around-methods before-methods
479     ;;; primary-method after-methods)
480     ;;;
481     ;;; where each method is a list (METHOD qualifiers specializers).
482     ;;;
483     (defvar *emf-name-table* (make-hash-table :test 'equal))
484    
485     (defun make-emf-name (gf methods)
486     (let* ((early-p (early-gf-p gf))
487     (gf-name (if early-p
488     (early-gf-name gf)
489     (generic-function-name gf)))
490     (emf-name
491     (if (or early-p
492     (eq (generic-function-method-combination gf)
493     *standard-method-combination*))
494     (let (primary around before after)
495     (dolist (m methods)
496     (let ((qual (if early-p
497     (early-method-qualifiers m)
498     (method-qualifiers m)))
499     (specl (if early-p
500     (early-method-specializers m)
501     (unparse-specializers
502     (method-specializers m)))))
503     (case (car-safe qual)
504     (:around (push `(method :around ,specl) around))
505     (:before (push `(method :before ,specl) before))
506     (:after (push `(method :after ,specl) after))
507     (t (push `(method ,specl) primary)))))
508     `(effective-method ,gf-name
509     ,@(nreverse around)
510     ,@(nreverse before)
511     ,@(list (last primary))
512     ,@after))
513     `(effective-method ,gf-name ,(gensym)))))
514     (or (gethash emf-name *emf-name-table*)
515     (setf (gethash emf-name *emf-name-table*) emf-name))))
516 ram 1.2
517 gerd 1.13.2.1 ;;; end of combin.lisp

  ViewVC Help
Powered by ViewVC 1.1.5