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 ;;;--------------------------------------------------------------------------
112 (defmethod check-message-type ((message aggregating-message) type)
113 (with-slots (combination) message
114 (check-aggregating-message-type message combination type)))
116 (defmethod sod-message-effective-method-class ((message aggregating-message))
117 'aggregating-effective-method)
119 (defmethod simple-method-body
120 ((method aggregating-effective-method) codegen target)
121 (let ((argument-names (effective-method-basic-argument-names method))
122 (primary-methods (effective-method-primary-methods method)))
123 (funcall (sod-message-kernel-function (effective-method-message method))
124 codegen target argument-names primary-methods)))
126 (defmethod shared-initialize :before
127 ((message aggregating-message) slot-names &key pset)
128 (declare (ignore slot-names))
129 (with-slots (combination plist kernel-function) message
130 (let ((most-specific (get-property pset :most-specific :keyword :first))
131 (comb (get-property pset :combination :keyword)))
133 ;; Check that we've been given a method combination and make sure it
136 (error "The `combination' property is required."))
137 (unless (some (lambda (method)
138 (let* ((specs (method-specializers method))
139 (message-spec (car specs))
140 (combination-spec (cadr specs)))
141 (and (typep message-spec 'class)
142 (typep message message-spec)
143 (typep combination-spec 'eql-specializer)
144 (eq (eql-specializer-object combination-spec)
146 (generic-function-methods
147 #'compute-aggregating-message-kernel))
148 (error "Unknown method combination `~(~A~)'." comb))
149 (setf combination comb)
151 ;; Make sure the ordering is actually valid.
152 (unless (member most-specific '(:first :last))
153 (error "The `most_specific' property must be `first' or `last'."))
155 ;; Set up the function which will compute the kernel.
156 (let ((magic (cons nil nil))
159 ;; Collect the property values wanted by the method combination.
160 (do ((want (aggregating-message-properties message comb)
163 (let* ((name (car want))
165 (prop (get-property pset name type magic)))
166 (unless (eq prop magic)
167 (setf keys (list* name prop keys)))))
170 ;; Set the kernel function for later.
171 (setf kernel-function
172 (lambda (codegen target arg-names methods)
173 (apply #'compute-aggregating-message-kernel
178 (:last (setf methods (reverse methods))))
182 (defmethod check-method-type
183 ((method sod-method) (message aggregating-message)
184 (type c-function-type))
185 (let ((wanted (aggregating-message-method-return-type
186 message (sod-message-combination message)))
187 (msgtype (sod-message-type message)))
188 (check-method-return-type type wanted)
189 (check-method-argument-lists type msgtype)))
191 ;;;--------------------------------------------------------------------------
194 (export 'define-aggregating-method-combination)
195 (defmacro define-aggregating-method-combination
198 &key (codegen (gensym "CODEGEN-"))
199 (methods (gensym "METHODS-")))
200 &key properties return-type
201 ((:around around-func) '#'funcall)
202 ((:first-method first-method-func) nil firstp)
203 ((:methods methods-func) '#'funcall))
204 "Utility macro for definining aggregating method combinations.
206 The VARS are a list of variable names to be bound to temporary variable
207 objects of the method's return type. Additional keyword arguments define
208 variables names to be bound to other possibly interesting values:
210 * CODEGEN is the `codegen' object passed at effective-method computation
213 * METHODS is the list of primary methods, in the order in which they
214 should be invoked. Note that this list must be non-empty, since
215 otherwise the method on `compute-effective-method-body' specialized to
216 `simple-effective-method' will suppress the method entirely.
218 The PROPERTIES, if specified, are a list of properties to be collected
219 during message-object initialization; items in the list have the form
221 (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
223 similar to a `&key' BVL entry, except for the additional TYPE entry. In
224 particular, a symbolic NAME may be written in place of a singleton list.
225 The KEYWORD names the property as it should be looked up in the pset,
226 while the NAME names a variable to which the property value or default is
229 All of these variables, and the VARS, are available in the functions
232 If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
233 on `check-aggregating-message-type' to check the that the message's return
234 type matches RETURN-TYPE.
236 The AROUND, FIRST-METHOD, and METHODS are function designators (probably
237 `lambda' forms) providing pieces of the aggregating behaviour.
239 The AROUND function is called first, with a single argument BODY, though
240 the variables above are also in scope. It is expected to emit code to
241 CODEGEN which invokes the METHODS in the appropriate order, and arranges
242 to store the aggregated return value in the first of the VARS.
244 It may call BODY as a function in order to assist with this; let ARGS be
245 the list of arguments supplied to it. The default behaviour is to call
246 BODY with no arguments. The BODY function first calls FIRST-METHOD,
247 passing it as arguments a function INVOKE and the ARGS which were passed
248 to BODY, and then calls METHODS once for each remaining method, again
249 passing an INVOKE function and the ARGS. If FIRST-METHOD is not
250 specified, then the METHODS function is used for all of the methods. If
251 METHODS is not specified, then the behaviour is simply to call INVOKE
252 immediately. (See the definition of the `:progn' method combination.)
254 Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
255 the appropriate direct method and deliver its return value to TARGET,
256 which defaults to `:void'."
258 (with-gensyms (type msg combvar target arg-names args want-type
259 meth targ func call-methfunc
260 aroundfunc fmethfunc methfunc)
263 ;; If properties are listed, arrange for them to be collected.
265 `((defmethod aggregating-message-properties
266 ((,msg aggregating-message) (,combvar (eql ',comb)))
267 ',(mapcan (lambda (prop)
268 (list (let* ((name (car prop))
269 (names (if (listp name) name
271 (if (cddr names) (car names)
272 (intern (car names) :keyword)))
276 ;; If a particular return type is wanted, check that.
278 `((defmethod check-aggregating-message-type
279 ((,msg aggregating-message)
280 (,combvar (eql ',comb))
281 (,type c-function-type))
282 (let ((,want-type (c-type ,return-type)))
283 (unless (c-type-equal-p (c-type-subtype ,type)
285 (error "Messages with `~(~A~)' combination ~
287 ,combvar ,want-type)))
288 (call-next-method))))
290 ;; Define the main kernel-compuation method.
291 (defmethod compute-aggregating-message-kernel
292 ((,msg aggregating-message) (,combvar (eql ',comb))
293 ,codegen ,target ,methods ,arg-names
294 &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
296 (declare (ignore ,combvar))
298 ;; Declare the necessary variables and give names to the functions
299 ;; supplied by the caller.
301 `((,type (c-type-subtype (sod-message-type ,msg)))))
302 ,@(mapcar (lambda (var)
303 (list var `(temporary-var ,codegen ,type)))
305 (,aroundfunc ,around-func)
306 (,methfunc ,methods-func)
307 (,fmethfunc ,(if firstp first-method-func methfunc)))
309 ;; Arrange to release the temporaries when we're finished with
314 ;; Wrap the AROUND function around most of the work.
316 (lambda (&rest ,args)
317 (flet ((,call-methfunc (,func ,meth)
318 ;; Call FUNC, passing it an INVOKE
319 ;; function which will generate a call
323 (&optional (,targ :void))
324 (invoke-method ,codegen
330 ;; The first method might need special
332 (,call-methfunc ,fmethfunc (car ,methods))
334 ;; Call the remaining methods in the right
336 (dolist (,meth (cdr ,methods))
337 (,call-methfunc ,methfunc ,meth)))))
339 ;; Outside the AROUND function now, deliver the final
340 ;; result to the right place.
341 (deliver-expr ,codegen ,target ,(car vars)))
343 ;; Finally, release the temporary variables.
344 ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
349 ;;;--------------------------------------------------------------------------
350 ;;; Fixed aggregating method combinations.
352 (define-aggregating-method-combination :progn (nil)
355 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
356 :first-method (lambda (invoke)
358 (emit-inst codegen (make-set-inst acc val)))
359 :methods (lambda (invoke)
361 (emit-inst codegen (make-update-inst acc #\+ val))))
363 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
364 :first-method (lambda (invoke)
366 (emit-inst codegen (make-set-inst acc val)))
367 :methods (lambda (invoke)
369 (emit-inst codegen (make-update-inst acc #\* val))))
371 (define-aggregating-method-combination :min ((acc val) :codegen codegen)
372 :first-method (lambda (invoke)
374 (emit-inst codegen (make-set-inst acc val)))
375 :methods (lambda (invoke)
377 (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
378 (make-set-inst acc val)))))
380 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
381 :first-method (lambda (invoke)
383 (emit-inst codegen (make-set-inst acc val)))
384 :methods (lambda (invoke)
386 (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
387 (make-set-inst acc val)))))
389 (define-aggregating-method-combination :and ((ret) :codegen codegen)
390 :around (lambda (body)
391 (codegen-push codegen)
394 (make-do-while-inst (codegen-pop-block codegen) 0)))
395 :methods (lambda (invoke)
397 (emit-inst codegen (make-if-inst (format nil "!~A" ret)
398 (make-break-inst)))))
400 (define-aggregating-method-combination :or ((ret) :codegen codegen)
401 :around (lambda (body)
402 (codegen-push codegen)
405 (make-do-while-inst (codegen-pop-block codegen) 0)))
406 :methods (lambda (invoke)
408 (emit-inst codegen (make-if-inst ret (make-break-inst)))))
410 ;;;--------------------------------------------------------------------------
411 ;;; A customizable aggregating method combination.
413 (defmethod aggregating-message-properties
414 ((message aggregating-message) (combination (eql :custom)))
425 (defmethod aggregating-message-method-return-type
426 ((message aggregating-message) (combination (eql :custom)))
427 (getf (sod-message-plist message) :methty
428 (c-type-subtype (sod-message-type message))))
430 (defmethod compute-aggregating-message-kernel
431 ((message aggregating-message) (combination (eql :custom))
432 codegen target methods arg-names
433 &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
434 decls before each (first each) after count)
435 (let* ((type (c-type-subtype (sod-message-type message)))
436 (methty (if methtyp methty type)))
437 (unless (eq type c-type-void)
438 (ensure-var codegen retvar type))
439 (unless (eq methty c-type-void)
440 (ensure-var codegen valvar methty))
442 (ensure-var codegen count c-type-size-t (length methods)))
444 (emit-decl codegen decls))
445 (labels ((maybe-emit (fragment)
446 (when fragment (emit-inst codegen fragment)))
447 (invoke (method fragment)
448 (invoke-method codegen
449 (if (eq methty c-type-void) :void valvar)
451 (maybe-emit fragment)))
453 (invoke (car methods) first)
454 (dolist (method (cdr methods)) (invoke method each))
456 (deliver-expr codegen target retvar))))
458 ;;;----- That's all, folks --------------------------------------------------