3 ;;; Aggregating method combinations
5 ;;; (c) 2015 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 ;;;--------------------------------------------------------------------------
29 ;;; Classes and protocol.
31 (export '(aggregating-message
32 sod-message-combination sod-message-kernel-function))
33 (defclass aggregating-message (simple-message)
34 ((combination :initarg :combination :type keyword
35 :reader sod-message-combination)
36 (plist :type list :accessor sod-message-plist)
37 (kernel-function :type function :reader sod-message-kernel-function))
39 "Message class for aggregating method combinations.
41 An aggregating method combination invokes the primary methods in order,
42 most-specific first, collecting their return values, and combining them
43 together in some way to produce a result for the effective method as a
46 Mostly, this is done by initializing an accumulator to some appropriate
47 value, updating it with the result of each primary method in turn, and
48 finally returning some appropriate output function of it. The order is
49 determined by the `:most-specific' property, which may have the value
52 The `progn' method combination is implemented as a slightly weird special
53 case of an aggregating method combination with a trivial state. More
54 typical combinations are `:sum', `:product', `:min', `:max', `:and', and
55 `:or'. Finally, there's a `custom' combination which uses user-supplied
56 code fragments to stitch everything together."))
58 (export 'aggregating-message-properties)
59 (defgeneric aggregating-message-properties (message combination)
61 "Return a description of the properties needed by the method COMBINATION.
63 The description should be a plist of alternating property name and type
64 keywords. The named properties will be looked up in the pset supplied at
65 initialization time, and supplied to `compute-aggregating-message-kernel'
66 as keyword arguments. Defaults can be supplied in method BVLs.
68 The default is not to capture any property values.
70 The reason for this is as not to retain the pset beyond message object
72 (:method (message combination) nil))
74 (export 'compute-aggregating-message-kernel)
75 (defgeneric compute-aggregating-message-kernel
76 (message combination codegen target methods arg-names &key)
78 "Determine how to aggregate the direct methods for an aggregating message.
80 The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
81 METHODS): it should emit, to CODEGEN, an appropriate effective-method
82 kernel which invokes the listed direct METHODS, in the appropriate order,
83 collects and aggregates their values, and delivers to TARGET the final
84 result of the method kernel.
86 The easy way to implement this method is to use the macro
87 `define-aggregating-method-combination'."))
89 (export 'check-aggregating-message-type)
90 (defgeneric check-aggregating-message-type (message combination type)
92 "Check that TYPE is an acceptable function TYPE for the COMBINATION.
94 For example, `progn' messages must return `void', while `and' and `or'
95 messages must return `int'.")
96 (:method (message combination type)
99 (defgeneric aggregating-message-method-return-type (message combination)
101 "Return the primary method return type for this MESSAGE and COMBINATION.")
102 (:method ((message aggregating-message) (combination t))
103 (c-type-subtype (sod-message-type message))))
105 (export 'aggregating-effective-method)
106 (defclass aggregating-effective-method (simple-effective-method) ()
107 (:documentation "Effective method counterpart to `aggregating-message'."))
109 (defgeneric aggregating-message-always-live-p (message combination)
111 "Return whether the method combination can work without primary methods.
113 Return non-nil if the corresponding effective method should be considered
114 live even if it doesn't have any methods.")
115 (:method ((message aggregating-message) (combination t)) nil))
117 (defmethod effective-method-live-p ((method aggregating-effective-method))
118 (or (let* ((message (effective-method-message method))
119 (comb (sod-message-combination message)))
120 (aggregating-message-always-live-p message comb))
123 ;;;--------------------------------------------------------------------------
126 (defmethod check-message-type ((message aggregating-message) type)
127 (with-slots (combination) message
128 (check-aggregating-message-type message combination type)))
130 (defmethod sod-message-effective-method-class ((message aggregating-message))
131 'aggregating-effective-method)
133 (defmethod simple-method-body
134 ((method aggregating-effective-method) codegen target)
135 (let ((argument-names (effective-method-basic-argument-names method))
136 (primary-methods (effective-method-primary-methods method)))
137 (funcall (sod-message-kernel-function (effective-method-message method))
138 codegen target argument-names primary-methods)))
140 (defmethod shared-initialize :before
141 ((message aggregating-message) slot-names &key pset)
142 (declare (ignore slot-names))
143 (with-slots (combination plist kernel-function) message
144 (let ((most-specific (get-property pset :most-specific :keyword :first))
145 (comb (get-property pset :combination :keyword)))
147 ;; Check that we've been given a method combination and make sure it
150 (error "The `combination' property is required"))
151 (unless (some (lambda (method)
152 (let* ((specs (method-specializers method))
153 (message-spec (car specs))
154 (combination-spec (cadr specs)))
155 (and (typep message-spec 'class)
156 (typep message message-spec)
157 (typep combination-spec 'eql-specializer)
158 (eq (eql-specializer-object combination-spec)
160 (generic-function-methods
161 #'compute-aggregating-message-kernel))
162 (error "Unknown method combination `~(~A~)'" comb))
163 (setf combination comb)
165 ;; Make sure the ordering is actually valid.
166 (unless (member most-specific '(:first :last))
167 (error "The `most_specific' property must be `first' or `last'"))
169 ;; Set up the function which will compute the kernel.
170 (let ((magic (cons nil nil))
173 ;; Collect the property values wanted by the method combination.
174 (do ((want (aggregating-message-properties message comb)
177 (let* ((name (car want))
179 (prop (get-property pset name type magic)))
180 (unless (eq prop magic)
181 (setf keys (list* name prop keys)))))
184 ;; Set the kernel function for later.
185 (setf kernel-function
186 (lambda (codegen target arg-names methods)
187 (apply #'compute-aggregating-message-kernel
192 (:last (setf methods (reverse methods))))
196 (defmethod check-method-type
197 ((method sod-method) (message aggregating-message)
198 (type c-function-type))
199 (let ((wanted (aggregating-message-method-return-type
200 message (sod-message-combination message)))
201 (msgtype (sod-message-type message)))
202 (check-method-return-type type wanted)
203 (check-method-argument-lists type msgtype)))
205 ;;;--------------------------------------------------------------------------
208 (export 'define-aggregating-method-combination)
209 (defmacro define-aggregating-method-combination
212 &key (codegen (gensym "CODEGEN-"))
213 (methods (gensym "METHODS-")))
214 &key properties return-type
215 ((:around around-func) '#'funcall)
216 ((:empty empty-func) nil emptyp)
217 ((:first-method first-method-func) nil firstp)
218 ((:methods methods-func) '#'funcall))
219 "Utility macro for definining aggregating method combinations.
221 The VARS are a list of variable names to be bound to temporary variable
222 objects of the method's return type. Additional keyword arguments define
223 variables names to be bound to other possibly interesting values:
225 * CODEGEN is the `codegen' object passed at effective-method computation
228 * METHODS is the list of primary methods, in the order in which they
229 should be invoked. Note that this list must be non-empty, since
230 otherwise the method on `compute-effective-method-body' specialized to
231 `simple-effective-method' will suppress the method entirely.
233 The PROPERTIES, if specified, are a list of properties to be collected
234 during message-object initialization; items in the list have the form
236 (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
238 similar to a `&key' BVL entry, except for the additional TYPE entry. In
239 particular, a symbolic NAME may be written in place of a singleton list.
240 The KEYWORD names the property as it should be looked up in the pset,
241 while the NAME names a variable to which the property value or default is
244 All of these variables, and the VARS, are available in the functions
247 If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
248 on `check-aggregating-message-type' to check the that the message's return
249 type matches RETURN-TYPE.
251 If an EMPTY function is given, then (a) it's OK if there are no primary
252 methods, because (b) the EMPTY function is called to set the return
253 value variable in this case. Note that EMPTY is only called when there
254 are no primary methods.
256 The AROUND, FIRST-METHOD, and METHODS are function designators (probably
257 `lambda' forms) providing pieces of the aggregating behaviour.
259 The AROUND function is called first, with a single argument BODY, though
260 the variables above are also in scope. It is expected to emit code to
261 CODEGEN which invokes the METHODS in the appropriate order, and arranges
262 to store the aggregated return value in the first of the VARS.
264 It may call BODY as a function in order to assist with this; let ARGS be
265 the list of arguments supplied to it. The default behaviour is to call
266 BODY with no arguments. The BODY function first calls FIRST-METHOD,
267 passing it as arguments a function INVOKE and the ARGS which were passed
268 to BODY, and then calls METHODS once for each remaining method, again
269 passing an INVOKE function and the ARGS. If FIRST-METHOD is not
270 specified, then the METHODS function is used for all of the methods. If
271 METHODS is not specified, then the behaviour is simply to call INVOKE
272 immediately. (See the definition of the `:progn' method combination.)
274 Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
275 the appropriate direct method and deliver its return value to TARGET,
276 which defaults to `:void'."
278 (with-gensyms (type msg combvar target arg-names args want-type
279 meth targ func call-methfunc
280 aroundfunc fmethfunc methfunc bodyfunc)
283 ;; If properties are listed, arrange for them to be collected.
285 `((defmethod aggregating-message-properties
286 ((,msg aggregating-message) (,combvar (eql ',comb)))
287 ',(mapcan (lambda (prop)
288 (list (let* ((name (car prop))
289 (names (if (listp name) name
291 (if (cddr names) (car names)
292 (intern (car names) :keyword)))
296 ;; If a particular return type is wanted, check that.
298 `((defmethod check-aggregating-message-type
299 ((,msg aggregating-message)
300 (,combvar (eql ',comb))
301 (,type c-function-type))
302 (let ((,want-type (c-type ,return-type)))
303 (unless (c-type-equal-p (c-type-subtype ,type)
305 (error "Messages with `~(~A~)' combination ~
307 ,combvar ,want-type)))
308 (call-next-method))))
310 ;; If there is an EMPTY function then the effective method is always
313 `((defmethod aggregating-message-always-live-p
314 ((,msg aggregating-message)
315 (,combvar (eql ',comb)))
318 ;; Define the main kernel-compuation method.
319 (defmethod compute-aggregating-message-kernel
320 ((,msg aggregating-message) (,combvar (eql ',comb))
321 ,codegen ,target ,methods ,arg-names
322 &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
324 (declare (ignore ,combvar))
326 ;; Declare the necessary variables and give names to the functions
327 ;; supplied by the caller.
329 `((,type (c-type-subtype (sod-message-type ,msg)))
330 (,(car vars) (temporary-var ,codegen ,type))))
331 ,@(mapcar (lambda (var)
332 (list var `(and ,methods
333 (temporary-var ,codegen ,type))))
335 (,aroundfunc ,around-func)
336 (,methfunc ,methods-func)
337 (,fmethfunc ,(if firstp first-method-func methfunc)))
341 (lambda (&rest ,args)
342 (flet ((,call-methfunc (,func ,meth)
343 ;; Call FUNC, passing it an INVOKE
344 ;; function which will generate a
348 (&optional (,targ :void))
349 (invoke-method ,codegen
355 ;; The first method might need special
357 (,call-methfunc ,fmethfunc (car ,methods))
359 ;; Call the remaining methods in the right
361 (dolist (,meth (cdr ,methods))
362 (,call-methfunc ,methfunc ,meth)))))))
364 ;; Arrange to release the temporaries when we're finished with
369 ;; If there are no direct methods, then just do the
370 ;; empty-effective-method thing to set the return
371 ;; variable. Otherwise, wrap AROUND round the main body.
374 (funcall ,empty-func)
378 ;; Outside the AROUND function now, deliver the final
379 ;; result to the right place.
380 (deliver-expr ,codegen ,target ,(car vars)))
382 ;; Finally, release the temporary variables.
383 ,@(mapcar (lambda (var)
384 `(when ,var (setf (var-in-use-p ,var) nil)))
389 ;;;--------------------------------------------------------------------------
390 ;;; Fixed aggregating method combinations.
392 (define-aggregating-method-combination :progn (nil)
394 :empty (lambda () nil))
396 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
397 :empty (lambda () (emit-inst codegen (make-set-inst acc 0)))
398 :first-method (lambda (invoke)
400 (emit-inst codegen (make-set-inst acc val)))
401 :methods (lambda (invoke)
403 (emit-inst codegen (make-update-inst acc #\+ val))))
405 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
406 :empty (lambda () (emit-inst codegen (make-set-inst acc 1)))
407 :first-method (lambda (invoke)
409 (emit-inst codegen (make-set-inst acc val)))
410 :methods (lambda (invoke)
412 (emit-inst codegen (make-update-inst acc #\* val))))
414 (define-aggregating-method-combination :min ((acc val) :codegen codegen)
415 :first-method (lambda (invoke)
417 (emit-inst codegen (make-set-inst acc val)))
418 :methods (lambda (invoke)
420 (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
421 (make-set-inst acc val)))))
423 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
424 :first-method (lambda (invoke)
426 (emit-inst codegen (make-set-inst acc val)))
427 :methods (lambda (invoke)
429 (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
430 (make-set-inst acc val)))))
432 (define-aggregating-method-combination :and ((ret) :codegen codegen)
433 :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))
434 :around (lambda (body)
435 (codegen-push codegen)
438 (make-do-while-inst (codegen-pop-block codegen) 0)))
439 :methods (lambda (invoke)
441 (emit-inst codegen (make-if-inst (format nil "!~A" ret)
442 (make-break-inst)))))
444 (define-aggregating-method-combination :or ((ret) :codegen codegen)
445 :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))
446 :around (lambda (body)
447 (codegen-push codegen)
450 (make-do-while-inst (codegen-pop-block codegen) 0)))
451 :methods (lambda (invoke)
453 (emit-inst codegen (make-if-inst ret (make-break-inst)))))
455 ;;;--------------------------------------------------------------------------
456 ;;; A customizable aggregating method combination.
458 (defmethod aggregating-message-properties
459 ((message aggregating-message) (combination (eql :custom)))
471 (defmethod aggregating-message-method-return-type
472 ((message aggregating-message) (combination (eql :custom)))
473 (getf (sod-message-plist message) :methty
474 (c-type-subtype (sod-message-type message))))
476 (defmethod aggregating-message-always-live-p
477 ((message aggregating-message) (combination (eql :custom)))
478 (getf (sod-message-plist message) :empty))
480 (defmethod compute-aggregating-message-kernel
481 ((message aggregating-message) (combination (eql :custom))
482 codegen target methods arg-names
483 &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
484 empty decls before each (first each) after count)
485 (let* ((type (c-type-subtype (sod-message-type message)))
486 (methty (if methtyp methty type)))
487 (unless (eq type c-type-void)
488 (ensure-var codegen retvar type))
489 (unless (or (null methods)
490 (eq methty c-type-void))
491 (ensure-var codegen valvar methty))
492 (when (and methods count)
493 (ensure-var codegen count c-type-size-t (length methods)))
494 (when (and methods decls)
495 (emit-decl codegen decls))
496 (labels ((maybe-emit (fragment)
497 (when fragment (emit-inst codegen fragment)))
498 (invoke (method fragment)
499 (invoke-method codegen
500 (if (eq methty c-type-void) :void valvar)
502 (maybe-emit fragment)))
503 (cond ((and empty (null methods))
504 (emit-inst codegen empty))
507 (invoke (car methods) first)
508 (dolist (method (cdr methods)) (invoke method each))
510 (deliver-expr codegen target retvar))))
512 ;;;----- That's all, folks --------------------------------------------------