3 ;;; Method combination implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible 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."))
45 (define-on-demand-slot basic-message argument-tail (message)
48 (if (or (eq arg :ellipsis) (argument-name arg)) arg
49 (make-argument (make-instance 'temporary-argument
52 (argument-type arg))))
53 (c-function-arguments (sod-message-type message)))))
55 (define-on-demand-slot basic-message no-varargs-tail (message)
57 (if (eq arg :ellipsis)
58 (make-argument *sod-ap* c-type-va-list)
60 (sod-message-argument-tail message)))
62 (defmethod sod-message-method-class
63 ((message basic-message) (class sod-class) pset)
64 (let ((role (get-property pset :role :keyword nil)))
66 ((:before :after) 'daemon-direct-method)
67 (:around 'delegating-direct-method)
68 ((nil) (error "How odd: a primary method slipped through the net"))
69 (t (error "Unknown method role ~A" role)))))
71 (export 'simple-message)
72 (defclass simple-message (basic-message)
75 "Base class for messages with `simple' method combinations.
77 A simple method combination is one which has only one method role other
78 than the `before', `after' and `around' methods provided by
79 `basic-message'. We call these `primary' methods, and the programmer
80 designates them by not specifying an explicit role.
82 If the programmer doesn't define any primary methods then the effective
83 method is null -- i.e., the method entry pointer shows up as a null
86 (defmethod sod-message-method-class
87 ((message simple-message) (class sod-class) pset)
88 (if (get-property pset :role :keyword nil)
90 (primary-method-class message)))
92 (defmethod primary-method-class ((message simple-message))
95 ;;;--------------------------------------------------------------------------
96 ;;; Direct method classes.
98 (export '(basic-direct-method sod-method-role))
99 (defclass basic-direct-method (sod-method)
100 ((role :initarg :role :type symbol :reader sod-method-role)
101 (function-type :type c-function-type :reader sod-method-function-type))
103 "Base class for built-in direct method classes.
105 Provides the basic functionality for the built-in direct-method classes.
106 This is a separate class so that `special effect' methods can avoid
107 inheriting its default behaviour and slots.
109 A basic method can be assigned a `role', which may be set either as an
110 initarg or using the `:role' property. Roles are used for method
113 The function type protocol is implemented on `basic-direct-method' using
114 slot reader methods."))
116 (defmethod shared-initialize :after
117 ((method basic-direct-method) slot-names &key pset)
118 (declare (ignore slot-names))
119 (default-slot (method 'role) (get-property pset :role :keyword nil)))
121 (define-on-demand-slot basic-direct-method function-type (method)
122 (let ((type (sod-method-type method)))
123 (c-type (fun (lisp (c-type-subtype type))
124 ("me" (* (class (sod-method-class method))))
125 . (c-function-arguments type)))))
127 (defmethod sod-method-function-name ((method basic-direct-method))
128 (with-slots ((class %class) role message) method
129 (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
130 (sod-class-nickname (sod-message-class message))
131 (sod-message-name message))))
133 (export 'daemon-direct-method)
134 (defclass daemon-direct-method (basic-direct-method)
137 "A daemon direct method is invoked for side effects and cannot override.
139 This is the direct method class for `before' and `after' methods, which
140 cannot choose to override the remaining methods and are not involved in
141 the computation of the final result.
143 In C terms, a daemon method must return `void', and is not passed a
144 `next_method' pointer."))
146 (defmethod check-method-type ((method daemon-direct-method)
147 (message sod-message)
148 (type c-function-type))
149 (with-slots ((msgtype %type)) message
150 (check-method-return-type type c-type-void)
151 (check-method-argument-lists type msgtype)))
153 (export 'delegating-direct-method)
154 (defclass delegating-direct-method (basic-direct-method)
155 ((next-method-type :type c-function-type
156 :reader sod-method-next-method-type))
158 "A delegating direct method can choose to override other methods.
160 This is the direct method class for `around' and standard-method-
161 combination primary methods, which are given the choice of computing the
162 entire method's result or delegating to (usually) less-specific methods.
164 In C terms, a delegating method is passed a `next_method' pointer so that
165 it can delegate part of its behaviour. (A delegating direct method for a
166 varargs message is also given an additional `va_list' argument,
167 conventionally named `sod__ap_master', which it is expected to pass on to
168 its `next_method' function if necessary.)
170 The function type protocol is implemented on `delegating-direct-method'
171 using slot reader methods.."))
173 (define-on-demand-slot delegating-direct-method next-method-type (method)
174 (let* ((message (sod-method-message method))
175 (return-type (c-type-subtype (sod-message-type message)))
176 (msgargs (sod-message-argument-tail message))
177 (arguments (if (varargs-message-p message)
178 (cons (make-argument *sod-master-ap* c-type-va-list)
181 (c-type (fun (lisp return-type)
182 ("me" (* (class (sod-method-class method))))
185 (define-on-demand-slot delegating-direct-method function-type (method)
186 (let* ((message (sod-method-message method))
187 (type (sod-method-type method))
188 (method-args (c-function-arguments type)))
189 (c-type (fun (lisp (c-type-subtype type))
190 ("me" (* (class (sod-method-class method))))
191 ("next_method" (* (lisp (commentify-function-type
192 (sod-method-next-method-type
195 (if (varargs-message-p message)
196 (cons (make-argument *sod-master-ap* c-type-va-list)
200 ;;;--------------------------------------------------------------------------
201 ;;; Effective method classes.
203 (export '(basic-effective-method
204 effective-method-around-methods effective-method-before-methods
205 effective-method-after-methods))
206 (defclass basic-effective-method (effective-method)
207 ((around-methods :initarg :around-methods :initform nil
208 :type list :reader effective-method-around-methods)
209 (before-methods :initarg :before-methods :initform nil
210 :type list :reader effective-method-before-methods)
211 (after-methods :initarg :after-methods :initform nil
212 :type list :reader effective-method-after-methods)
213 (basic-argument-names :type list
214 :reader effective-method-basic-argument-names)
215 (functions :type list :reader effective-method-functions))
217 "Base class for built-in effective method classes.
219 This class maintains lists of the applicable `before', `after' and
220 `around' methods and provides behaviour for invoking these methods
223 The argument names protocol is implemented on `basic-effective-method'
224 using a slot reader method."))
226 (define-on-demand-slot basic-effective-method basic-argument-names (method)
227 (let ((message (effective-method-message method)))
228 (mapcar #'argument-name
229 (sod-message-no-varargs-tail message))))
231 (defmethod effective-method-function-name ((method effective-method))
232 (let* ((class (effective-method-class method))
233 (message (effective-method-message method))
234 (message-class (sod-message-class message)))
235 (format nil "~A__emethod_~A__~A"
237 (sod-class-nickname message-class)
238 (sod-message-name message))))
240 (define-on-demand-slot basic-effective-method functions (method)
241 (compute-method-entry-functions method))
243 (export 'simple-effective-method)
244 (defclass simple-effective-method (basic-effective-method)
245 ((primary-methods :initarg :primary-methods :initform nil
246 :type list :reader effective-method-primary-methods))
248 "Effective method counterpart to `simple-message'."))
250 (defmethod shared-initialize :after
251 ((method simple-effective-method) slot-names &key direct-methods)
252 (declare (ignore slot-names))
253 (categorize (method direct-methods :bind ((role (sod-method-role method))))
254 ((primary (null role))
255 (before (eq role :before))
256 (after (eq role :after))
257 (around (eq role :around)))
258 (with-slots (primary-methods before-methods after-methods around-methods)
260 (setf primary-methods primary
261 before-methods before
262 after-methods (reverse after)
263 around-methods around))))
265 ;;;--------------------------------------------------------------------------
268 (defmethod shared-initialize :after
269 ((codegen method-codegen) slot-names &key)
270 (declare (ignore slot-names))
271 (with-slots (message target) codegen
273 (if (eq (c-type-subtype (sod-message-type message)) c-type-void)
277 ;;;--------------------------------------------------------------------------
278 ;;; Invoking direct methods.
280 (export 'basic-effective-method-body)
281 (defun basic-effective-method-body (codegen target method body)
282 "Build the common method-invocation structure.
284 Writes to CODEGEN some basic method-invocation instructions. It invokes
285 the `around' methods, from most- to least-specific. If they all delegate,
286 then the `before' methods are run, most-specific first; next, the
287 instructions generated by BODY (invoked with a target argument); then, the
288 `after' methods are run, least-specific first; and, finally, the value
289 delivered by the BODY is returned to the `around' methods. The result
290 returned by the outermost `around' method -- or, if there are none,
291 delivered by the BODY -- is finally delivered to the TARGET."
293 (with-slots (message (class %class)
294 before-methods after-methods around-methods)
296 (let* ((message-type (sod-message-type message))
297 (return-type (c-type-subtype message-type))
298 (basic-tail (effective-method-basic-argument-names method)))
299 (flet ((method-kernel (target)
300 (dolist (before before-methods)
301 (invoke-method codegen :void basic-tail before))
302 (if (null after-methods)
303 (funcall body target)
304 (convert-stmts codegen target return-type
306 (funcall body target)
307 (dolist (after (reverse after-methods))
308 (invoke-method codegen :void
309 basic-tail after)))))))
310 (invoke-delegation-chain codegen target basic-tail
311 around-methods #'method-kernel)))))
313 ;;;--------------------------------------------------------------------------
314 ;;; Method entry points.
316 (defparameter *method-entry-inline-threshold* 200
317 "Threshold below which effective method bodies are inlined into entries.
319 After the effective method body has been computed, we calculate its
320 metric, multiply by the number of entries we need to generate, and compare
321 it with this threshold. If the metric is below the threshold then we
322 fold the method body into the entry functions; otherwise we split the
323 effective method out into its own function.")
325 (defmethod method-entry-function-name
326 ((method effective-method) (chain-head sod-class) role)
327 (let* ((class (effective-method-class method))
328 (message (effective-method-message method))
329 (message-class (sod-message-class message)))
330 (if (or (not (slot-boundp method 'functions))
331 (slot-value method 'functions))
332 (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
334 (sod-class-nickname message-class)
335 (sod-message-name message)
336 (sod-class-nickname chain-head))
339 (defmethod method-entry-slot-name ((entry method-entry))
340 (let* ((method (method-entry-effective-method entry))
341 (message (effective-method-message method))
342 (name (sod-message-name message))
343 (role (method-entry-role entry)))
344 (method-entry-slot-name-by-role entry role name)))
346 (defmethod method-entry-function-type ((entry method-entry))
347 (let* ((method (method-entry-effective-method entry))
348 (message (effective-method-message method))
349 (type (sod-message-type message))
350 (tail (ecase (method-entry-role entry)
351 ((nil) (sod-message-argument-tail message))
352 (:valist (sod-message-no-varargs-tail message)))))
353 (c-type (fun (lisp (c-type-subtype type))
354 ("me" (* (class (method-entry-chain-tail entry))))
357 (defmethod make-method-entries ((method basic-effective-method)
358 (chain-head sod-class)
359 (chain-tail sod-class))
361 (message (effective-method-message method)))
363 (push (make-instance 'method-entry
364 :method method :role role
365 :chain-head chain-head
366 :chain-tail chain-tail)
368 (when (varargs-message-p message) (make :valist))
372 (defmethod compute-method-entry-functions ((method basic-effective-method))
374 ;; OK, there's quite a lot of this, so hold tight.
376 ;; The first thing we need to do is find all of the related objects. This
377 ;; is a bit verbose but fairly straightforward.
379 ;; Next, we generate the effective method body -- using `compute-effective-
380 ;; method-body' of all things. This gives us the declarations and body for
381 ;; an effective method function, but we don't have an actual function yet.
383 ;; Now we look at the chains which are actually going to need a method
384 ;; entry: only those chains whose tail (most specific) class is a
385 ;; superclass of the class which defined the message need an entry. We
386 ;; build a list of these tail classes.
388 ;; Having done this, we decide whether it's better to generate a standalone
389 ;; effective-method function and call it from each of the method entries,
390 ;; or to inline the effective method body into each of the entries.
392 ;; Most of the complexity here comes from (a) dealing with the two
393 ;; different strategies for constructing method entry functions and (b)
394 ;; (unsurprisingly) the mess involved with dealing with varargs messages.
396 (let* ((message (effective-method-message method))
397 (class (effective-method-class method))
398 (message-class (sod-message-class message))
399 (return-type (c-type-subtype (sod-message-type message)))
400 (codegen (make-instance 'method-codegen
405 ;; Method entry details.
406 (chain-tails (remove-if-not (lambda (super)
407 (sod-subclass-p super message-class))
409 (sod-class-chains class))))
410 (n-entries (length chain-tails))
411 (raw-entry-args (sod-message-argument-tail message))
412 (entry-args (sod-message-no-varargs-tail message))
413 (parm-n (let ((tail (last raw-entry-args 2)))
414 (and tail (eq (cadr tail) :ellipsis) (car tail))))
415 (entry-target (codegen-target codegen))
417 ;; Effective method function details.
418 (emf-name (effective-method-function-name method))
419 (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
420 (emf-type (c-type (fun (lisp return-type)
421 ("sod__obj" (lisp ilayout-type))
424 (flet ((setup-entry (tail)
425 (let ((head (sod-class-chain-head tail)))
426 (codegen-push codegen)
427 (ensure-var codegen "sod__obj" ilayout-type
428 (make-convert-to-ilayout-inst class
431 (let* ((head (sod-class-chain-head tail))
432 (role (if parm-n :valist nil))
433 (name (method-entry-function-name method head role))
434 (type (c-type (fun (lisp return-type)
435 ("me" (* (class tail)))
437 (codegen-pop-function codegen name type
438 "~@(~@[~A ~]entry~) function ~:_~
439 for method `~A.~A' ~:_~
440 via chain headed by `~A' ~:_~
442 (if parm-n "Indirect argument-tail" nil)
443 (sod-class-nickname message-class)
444 (sod-message-name message)
447 ;; If this is a varargs method then we've made the
448 ;; `:valist' role. Also make the `nil' role.
450 (let ((call (apply #'make-call-inst name "me"
451 (mapcar #'argument-name entry-args)))
452 (main (method-entry-function-name method head nil))
453 (main-type (c-type (fun (lisp return-type)
454 ("me" (* (class tail)))
456 (codegen-push codegen)
457 (ensure-var codegen *sod-ap* c-type-va-list)
458 (convert-stmts codegen entry-target return-type
460 (deliver-call codegen :void "va_start"
462 (deliver-expr codegen target call)
463 (deliver-call codegen :void "va_end"
465 (codegen-pop-function codegen main main-type
466 "Variable-length argument list ~:_~
468 for method `~A.~A' ~:_~
469 via chain headed by `~A' ~:_~
471 (sod-class-nickname message-class)
472 (sod-message-name message)
475 ;; Generate the method body. We'll work out what to do with it later.
476 (codegen-push codegen)
477 (let* ((result (if (eq return-type c-type-void) nil
478 (temporary-var codegen return-type)))
479 (emf-target (or result :void)))
480 (compute-effective-method-body method codegen emf-target)
481 (multiple-value-bind (vars insts) (codegen-pop codegen)
482 (cond ((or (= n-entries 1)
483 (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
484 *method-entry-inline-threshold*))
486 ;; The effective method body is simple -- or there's only
487 ;; one of them. We'll inline the method body into the entry
489 (dolist (tail chain-tails)
492 (if (typep var 'var-inst)
493 (ensure-var codegen (inst-name var)
494 (inst-type var) (inst-init var))
495 (emit-decl codegen var)))
496 (emit-insts codegen insts)
497 (deliver-expr codegen entry-target result)
498 (finish-entry tail)))
502 ;; The effective method body is complicated and we'd need
503 ;; more than one copy. We'll generate an effective method
504 ;; function and call it a lot.
505 (codegen-build-function codegen emf-name emf-type vars
506 (nconc insts (and result
507 (list (make-return-inst result))))
508 "Effective method function ~:_for `~A.~A' ~:_~
510 (sod-class-nickname message-class)
511 (sod-message-name message)
512 (effective-method-class method))
514 (let ((call (apply #'make-call-inst emf-name "sod__obj"
515 (mapcar #'argument-name entry-args))))
516 (dolist (tail chain-tails)
518 (deliver-expr codegen entry-target call)
519 (finish-entry tail)))))))
521 (codegen-functions codegen))))
523 (defmethod compute-method-entry-functions
524 ((method simple-effective-method))
525 (if (effective-method-primary-methods method)
529 (defmethod compute-effective-method-body
530 ((method simple-effective-method) codegen target)
531 (basic-effective-method-body codegen target method
533 (simple-method-body method
537 ;;;--------------------------------------------------------------------------
538 ;;; Standard method combination.
540 (export 'standard-message)
541 (defclass standard-message (simple-message)
544 "Message class for standard method combinations.
546 Standard method combination is a simple method combination where the
547 primary methods are invoked as a delegation chain, from most- to
550 (export 'standard-effective-method)
551 (defclass standard-effective-method (simple-effective-method) ()
552 (:documentation "Effective method counterpart to `standard-message'."))
554 (defmethod primary-method-class ((message standard-message))
555 'delegating-direct-method)
557 (defmethod sod-message-effective-method-class ((message standard-message))
558 'standard-effective-method)
560 (defmethod simple-method-body
561 ((method standard-effective-method) codegen target)
562 (invoke-delegation-chain codegen
564 (effective-method-basic-argument-names method)
565 (effective-method-primary-methods method)
568 ;;;----- That's all, folks --------------------------------------------------