3 ;;; Method combination implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
31 (export 'basic-message)
32 (defclass basic-message (sod-message)
33 ((argument-tail :type list :reader sod-message-argument-tail)
34 (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
36 "Base class for built-in message classes.
38 Provides the basic functionality for the built-in method combinations.
39 This is a separate class so that `special effect' messages can avoid
40 inheriting its default behaviour.
42 The function type protocol is implemented on `basic-message' using slot
43 reader methods. The actual values are computed on demand in methods
44 defined on `slot-unbound'."))
46 (defmethod slot-unbound (class
47 (message basic-message)
48 (slot-name (eql 'argument-tail)))
49 (declare (ignore class))
51 (setf (slot-value message 'argument-tail)
53 (if (or (eq arg :ellipsis) (argument-name arg)) arg
54 (make-argument (make-instance 'temporary-argument
57 (argument-type arg))))
58 (c-function-arguments (sod-message-type message))))))
60 (defmethod slot-unbound (class
61 (message basic-message)
62 (slot-name (eql 'no-varargs-tail)))
63 (declare (ignore class))
64 (setf (slot-value message 'no-varargs-tail)
66 (if (eq arg :ellipsis)
67 (make-argument *sod-ap* (c-type va-list))
69 (sod-message-argument-tail message))))
71 (defmethod sod-message-method-class
72 ((message basic-message) (class sod-class) pset)
73 (let ((role (get-property pset :role :keyword nil)))
75 ((:before :after) 'daemon-direct-method)
76 (:around 'delegating-direct-method)
77 ((nil) (error "How odd: a primary method slipped through the net"))
78 (t (error "Unknown method role ~A" role)))))
80 (export 'simple-message)
81 (defclass simple-message (basic-message)
84 "Base class for messages with `simple' method combinations.
86 A simple method combination is one which has only one method role other
87 than the `before', `after' and `around' methods provided by
88 `basic-message'. We call these `primary' methods, and the programmer
89 designates them by not specifying an explicit role.
91 If the programmer doesn't define any primary methods then the effective
92 method is null -- i.e., the method entry pointer shows up as a null
95 (defmethod sod-message-method-class
96 ((message simple-message) (class sod-class) pset)
97 (if (get-property pset :role :keyword nil)
99 (primary-method-class message)))
101 ;;;--------------------------------------------------------------------------
102 ;;; Direct method classes.
104 (export 'basic-direct-method)
105 (defclass basic-direct-method (sod-method)
106 ((role :initarg :role :type symbol :reader sod-method-role)
107 (function-type :type c-function-type :reader sod-method-function-type))
109 "Base class for built-in direct method classes.
111 Provides the basic functionality for the built-in direct-method classes.
112 This is a separate class so that `special effect' methods can avoid
113 inheriting its default behaviour and slots.
115 A basic method can be assigned a `role', which may be set either as an
116 initarg or using the `:role' property. Roles are used for method
119 The function type protocol is implemented on `basic-direct-method' using
120 slot reader methods. The actual values are computed on demand in methods
121 defined on `slot-unbound'."))
123 (defmethod shared-initialize :after
124 ((method basic-direct-method) slot-names &key pset)
125 (declare (ignore slot-names))
126 (default-slot (method 'role) (get-property pset :role :keyword nil)))
128 (defmethod slot-unbound
129 (class (method basic-direct-method) (slot-name (eql 'function-type)))
130 (declare (ignore class))
131 (let ((type (sod-method-type method)))
132 (setf (slot-value method 'function-type)
133 (c-type (fun (lisp (c-type-subtype type))
134 ("me" (* (class (sod-method-class method))))
135 . (c-function-arguments type))))))
137 (defmethod sod-method-function-name ((method basic-direct-method))
138 (with-slots (class role message) method
139 (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
140 (sod-class-nickname (sod-message-class message))
141 (sod-message-name message))))
143 (export 'daemon-direct-method)
144 (defclass daemon-direct-method (basic-direct-method)
147 "A daemon direct method is invoked for side effects and cannot override.
149 This is the direct method class for `before' and `after' methods, which
150 cannot choose to override the remaining methods and are not involved in
151 the computation of the final result.
153 In C terms, a daemon method must return `void', and is not passed a
154 `next_method' pointer."))
156 (defmethod check-method-type ((method daemon-direct-method)
157 (message sod-message)
158 (type c-function-type))
159 (with-slots ((msgtype type)) message
160 (unless (c-type-equal-p (c-type-subtype type) (c-type void))
161 (error "Method return type ~A must be `void'" (c-type-subtype type)))
162 (unless (argument-lists-compatible-p (c-function-arguments msgtype)
163 (c-function-arguments type))
164 (error "Method arguments ~A don't match message ~A" type msgtype))))
166 (export 'delegating-direct-method)
167 (defclass delegating-direct-method (basic-direct-method)
168 ((next-method-type :type c-function-type
169 :reader sod-method-next-method-type))
171 "A delegating direct method can choose to override other methods.
173 This is the direct method class for `around' and standard-method-
174 combination primary methods, which are given the choice of computing the
175 entire method's result or delegating to (usually) less-specific methods.
177 In C terms, a delegating method is passed a `next_method' pointer so that
178 it can delegate part of its behaviour. (A delegating direct method for a
179 varargs message is also given an additional `va_list' argument,
180 conventionally named `sod__ap_master', which it is expected to pass on to
181 its `next_method' function if necessary.)
183 The function type protocol is implemented on `delegating-direct-method'
184 using slot reader methods. The actual values are computed on demand in
185 methods defined on `slot-unbound'."))
187 (defmethod slot-unbound (class
188 (method delegating-direct-method)
189 (slot-name (eql 'next-method-type)))
190 (declare (ignore class))
191 (let* ((message (sod-method-message method))
192 (type (sod-message-type message)))
193 (setf (slot-value method 'next-method-type)
194 (c-type (fun (lisp (c-type-subtype type))
195 ("me" (* (class (sod-method-class method))))
196 . (c-function-arguments type))))))
198 (defmethod slot-unbound (class
199 (method delegating-direct-method)
200 (slot-name (eql 'function-type)))
201 (declare (ignore class))
202 (let* ((message (sod-method-message method))
203 (type (sod-method-type method))
204 (method-args (c-function-arguments type)))
205 (setf (slot-value method 'function-type)
206 (c-type (fun (lisp (c-type-subtype type))
207 ("me" (* (class (sod-method-class method))))
208 ("next_method" (* (lisp (commentify-function-type
209 (sod-method-next-method-type
212 (if (varargs-message-p message)
213 (cons (make-argument *sod-master-ap*
218 ;;;--------------------------------------------------------------------------
219 ;;; Effective method classes.
221 (export 'basic-effective-method)
222 (defclass basic-effective-method (effective-method)
223 ((around-methods :initarg :around-methods :initform nil
224 :type list :reader effective-method-around-methods)
225 (before-methods :initarg :before-methods :initform nil
226 :type list :reader effective-method-before-methods)
227 (after-methods :initarg :after-methods :initform nil
228 :type list :reader effective-method-after-methods)
229 (basic-argument-names :type list
230 :reader effective-method-basic-argument-names)
231 (functions :type list :reader effective-method-functions))
233 "Base class for built-in effective method classes.
235 This class maintains lists of the applicable `before', `after' and
236 `around' methods and provides behaviour for invoking these methods
239 The argument names protocol is implemented on `basic-effective-method'
240 using a slot reader method. The actual values are computed on demand in
241 methods defined on `slot-unbound'."))
243 (defmethod slot-unbound (class
244 (method basic-effective-method)
245 (slot-name (eql 'basic-argument-names)))
246 (declare (ignore class))
247 (let ((message (effective-method-message method)))
248 (setf (slot-value method 'basic-argument-names)
249 (subst *sod-master-ap* *sod-ap*
250 (mapcar #'argument-name
251 (sod-message-no-varargs-tail message))))))
253 (defmethod effective-method-function-name ((method effective-method))
254 (let* ((class (effective-method-class method))
255 (message (effective-method-message method))
256 (message-class (sod-message-class message)))
257 (format nil "~A__emethod_~A__~A"
259 (sod-class-nickname message-class)
260 (sod-message-name message))))
262 (defmethod slot-unbound
263 (class (method basic-effective-method) (slot-name (eql 'functions)))
264 (declare (ignore class))
265 (setf (slot-value method 'functions)
266 (compute-method-entry-functions method)))
268 (export 'simple-effective-method)
269 (defclass simple-effective-method (basic-effective-method)
270 ((primary-methods :initarg :primary-methods :initform nil
271 :type list :reader effective-method-primary-methods))
273 "Effective method counterpart to `simple-message'."))
275 (defmethod shared-initialize :after
276 ((method simple-effective-method) slot-names &key direct-methods)
277 (declare (ignore slot-names))
278 (categorize (method direct-methods :bind ((role (sod-method-role method))))
279 ((primary (null role))
280 (before (eq role :before))
281 (after (eq role :after))
282 (around (eq role :around)))
283 (with-slots (primary-methods before-methods after-methods around-methods)
285 (setf primary-methods primary
286 before-methods before
287 after-methods (reverse after)
288 around-methods around))))
290 ;;;--------------------------------------------------------------------------
293 (defmethod shared-initialize :after
294 ((codegen method-codegen) slot-names &key)
295 (declare (ignore slot-names))
296 (with-slots (message target) codegen
298 (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
302 ;;;--------------------------------------------------------------------------
303 ;;; Invoking direct methods.
305 (export 'basic-effective-method-body)
306 (defun basic-effective-method-body (codegen target method body)
307 "Build the common method-invocation structure.
309 Writes to CODEGEN some basic method-invocation instructions. It invokes
310 the `around' methods, from most- to least-specific. If they all delegate,
311 then the `before' methods are run, most-specific first; next, the
312 instructions generated by BODY (invoked with a target argument); then, the
313 `after' methods are run, least-specific first; and, finally, the value
314 delivered by the BODY is returned to the `around' methods. The result
315 returned by the outermost `around' method -- or, if there are none,
316 delivered by the BODY -- is finally delivered to the TARGET."
318 (with-slots (message class before-methods after-methods around-methods)
320 (let* ((message-type (sod-message-type message))
321 (return-type (c-type-subtype message-type))
322 (voidp (eq return-type (c-type void)))
323 (basic-tail (effective-method-basic-argument-names method)))
324 (flet ((method-kernel (target)
325 (dolist (before before-methods)
326 (invoke-method codegen :void basic-tail before))
327 (if (or voidp (null after-methods))
328 (funcall body target)
329 (convert-stmts codegen target return-type
331 (funcall body target)
332 (dolist (after (reverse after-methods))
333 (invoke-method codegen :void
334 after basic-tail)))))))
335 (invoke-delegation-chain codegen target basic-tail
336 around-methods #'method-kernel)))))
338 ;;;--------------------------------------------------------------------------
339 ;;; Method entry points.
341 (defparameter *method-entry-inline-threshold* 200
342 "Threshold below which effective method bodies are inlined into entries.
344 After the effective method body has been computed, we calculate its
345 metric, multiply by the number of entries we need to generate, and compare
346 it with this threshold. If the metric is below the threshold then we
347 fold the method body into the entry functions; otherwise we split the
348 effective method out into its own function.")
350 (defmethod method-entry-function-name
351 ((method effective-method) (chain-head sod-class))
352 (let* ((class (effective-method-class method))
353 (message (effective-method-message method))
354 (message-class (sod-message-class message)))
355 (if (or (not (slot-boundp method 'functions))
356 (slot-value method 'functions))
357 (format nil "~A__mentry_~A__~A__chain_~A"
359 (sod-class-nickname message-class)
360 (sod-message-name message)
361 (sod-class-nickname chain-head))
364 (defmethod method-entry-function-type ((entry method-entry))
365 (let* ((method (method-entry-effective-method entry))
366 (message (effective-method-message method))
367 (type (sod-message-type message)))
368 (c-type (fun (lisp (c-type-subtype type))
369 ("me" (* (class (method-entry-chain-tail entry))))
370 . (sod-message-argument-tail message)))))
372 (defmethod make-method-entry ((method basic-effective-method)
373 (chain-head sod-class) (chain-tail sod-class))
374 (make-instance 'method-entry
376 :chain-head chain-head
377 :chain-tail chain-tail))
379 (defmethod compute-method-entry-functions ((method basic-effective-method))
381 ;; OK, there's quite a lot of this, so hold tight.
383 ;; The first thing we need to do is find all of the related objects. This
384 ;; is a bit verbose but fairly straightforward.
386 ;; Next, we generate the effective method body -- using `compute-effective-
387 ;; method-body' of all things. This gives us the declarations and body for
388 ;; an effective method function, but we don't have an actual function yet.
390 ;; Now we look at the chains which are actually going to need a method
391 ;; entry: only those chains whose tail (most specific) class is a
392 ;; superclass of the class which defined the message need an entry. We
393 ;; build a list of these tail classes.
395 ;; Having done this, we decide whether it's better to generate a standalone
396 ;; effective-method function and call it from each of the method entries,
397 ;; or to inline the effective method body into each of the entries.
399 ;; Most of the complexity here comes from (a) dealing with the two
400 ;; different strategies for constructing method entry functions and (b)
401 ;; (unsurprisingly) the mess involved with dealing with varargs messages.
403 (let* ((message (effective-method-message method))
404 (class (effective-method-class method))
405 (message-class (sod-message-class message))
406 (return-type (c-type-subtype (sod-message-type message)))
407 (codegen (make-instance 'method-codegen
412 ;; Effective method function details.
413 (emf-name (effective-method-function-name method))
414 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
415 (emf-arg-tail (mapcar (lambda (arg)
416 (if (eq (argument-name arg) *sod-ap*)
417 (make-argument *sod-master-ap*
420 (sod-message-no-varargs-tail message)))
421 (emf-type (c-type (fun (lisp return-type)
422 ("sod__obj" (lisp ilayout-type))
423 . (sod-message-no-varargs-tail message))))
424 (result (if (eq return-type (c-type void)) nil
425 (temporary-var codegen return-type)))
426 (emf-target (or result :void))
428 ;; Method entry details.
429 (chain-tails (remove-if-not (lambda (super)
430 (sod-subclass-p super message-class))
432 (sod-class-chains class))))
433 (n-entries (length chain-tails))
434 (entry-args (sod-message-argument-tail message))
435 (parm-n (do ((prev "me" (car args))
436 (args entry-args (cdr args)))
438 (when (eq (car args) :ellipsis)
440 (entry-target (codegen-target codegen)))
442 (flet ((setup-entry (tail)
443 (let ((head (sod-class-chain-head tail)))
444 (codegen-push codegen)
445 (ensure-var codegen "sod__obj" ilayout-type
446 (make-convert-to-ilayout-inst class
449 (ensure-var codegen *sod-master-ap* (c-type va-list))
451 (make-va-start-inst *sod-master-ap* parm-n)))
453 (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
455 (let* ((head (sod-class-chain-head tail))
456 (name (method-entry-function-name method head))
457 (type (c-type (fun (lisp return-type)
458 ("me" (* (class tail)))
460 (codegen-pop-function codegen name type))))
462 ;; Generate the method body. We'll work out what to do with it later.
463 (codegen-push codegen)
464 (compute-effective-method-body method codegen emf-target)
465 (multiple-value-bind (vars insts) (codegen-pop codegen)
466 (cond ((or (= n-entries 1)
467 (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
468 *method-entry-inline-threshold*))
470 ;; The effective method body is simple -- or there's only one
471 ;; of them. We'll inline the method body into the entry
473 (dolist (tail chain-tails)
476 (ensure-var codegen (inst-name var)
477 (inst-type var) (inst-init var)))
478 (when parm-n (varargs-prologue))
479 (emit-insts codegen insts)
480 (when parm-n (varargs-epilogue))
481 (deliver-expr codegen entry-target result)
482 (finish-entry tail)))
486 ;; The effective method body is complicated and we'd need more
487 ;; than one copy. We'll generate an effective method function
488 ;; and call it a lot.
489 (codegen-build-function codegen emf-name emf-type vars
490 (nconc insts (and result (list (make-return-inst result)))))
492 (let ((call (make-call-inst emf-name
493 (cons "sod__obj" (mapcar #'argument-name
495 (dolist (tail chain-tails)
499 (convert-stmts codegen entry-target return-type
501 (deliver-expr codegen target call)
502 (varargs-epilogue))))
504 (deliver-expr codegen entry-target call)))
505 (finish-entry tail))))))
507 (codegen-functions codegen))))
509 (defmethod compute-method-entry-functions
510 ((method simple-effective-method))
511 (if (effective-method-primary-methods method)
515 (defmethod compute-effective-method-body
516 ((method simple-effective-method) codegen target)
517 (with-slots (message basic-argument-names primary-methods) method
518 (basic-effective-method-body codegen target method
520 (simple-method-body method
524 ;;;--------------------------------------------------------------------------
525 ;;; Standard method combination.
527 (export 'standard-message)
528 (defclass standard-message (simple-message)
531 "Message class for standard method combination.
533 Standard method combination is a simple method combination where the
534 primary methods are invoked as a delegation chain, from most- to
537 (export 'standard-effective-method)
538 (defclass standard-effective-method (simple-effective-method) ()
539 (:documentation "Effective method counterpart to `standard-message'."))
541 (defmethod primary-method-class ((message standard-message))
542 'delegating-direct-method)
544 (defmethod message-effective-method-class ((message standard-message))
545 'standard-effective-method)
547 (defmethod simple-method-body
548 ((method standard-effective-method) codegen target)
549 (invoke-delegation-chain codegen
551 (effective-method-basic-argument-names method)
552 (effective-method-primary-methods method)
555 ;;;----- That's all, folks --------------------------------------------------