| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Aggregating method combinations |
| 4 | ;;; |
| 5 | ;;; (c) 2015 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 11 | ;;; |
| 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. |
| 16 | ;;; |
| 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. |
| 21 | ;;; |
| 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. |
| 25 | |
| 26 | (cl:in-package #:sod) |
| 27 | |
| 28 | ;;;-------------------------------------------------------------------------- |
| 29 | ;;; Classes and protocol. |
| 30 | |
| 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)) |
| 38 | (:documentation |
| 39 | "Message class for aggregating method combinations. |
| 40 | |
| 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 |
| 44 | whole. |
| 45 | |
| 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 |
| 50 | `:first' or `:last'. |
| 51 | |
| 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.")) |
| 57 | |
| 58 | (export 'aggregating-message-properties) |
| 59 | (defgeneric aggregating-message-properties (message combination) |
| 60 | (:documentation |
| 61 | "Return a description of the properties needed by the method COMBINATION. |
| 62 | |
| 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. |
| 67 | |
| 68 | The default is not to capture any property values. |
| 69 | |
| 70 | The reason for this is as not to retain the pset beyond message object |
| 71 | initialization.") |
| 72 | (:method (message combination) nil)) |
| 73 | |
| 74 | (export 'compute-aggregating-message-kernel) |
| 75 | (defgeneric compute-aggregating-message-kernel |
| 76 | (message combination codegen target methods arg-names &key) |
| 77 | (:documentation |
| 78 | "Determine how to aggregate the direct methods for an aggregating message. |
| 79 | |
| 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. |
| 85 | |
| 86 | The easy way to implement this method is to use the macro |
| 87 | `define-aggregating-method-combination'.")) |
| 88 | |
| 89 | (export 'check-aggregating-message-type) |
| 90 | (defgeneric check-aggregating-message-type (message combination type) |
| 91 | (:documentation |
| 92 | "Check that TYPE is an acceptable function TYPE for the COMBINATION. |
| 93 | |
| 94 | For example, `progn' messages must return `void', while `and' and `or' |
| 95 | messages must return `int'.") |
| 96 | (:method (message combination type) |
| 97 | t)) |
| 98 | |
| 99 | (defgeneric aggregating-message-method-return-type (message combination) |
| 100 | (:documentation |
| 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)))) |
| 104 | |
| 105 | (export 'aggregating-effective-method) |
| 106 | (defclass aggregating-effective-method (simple-effective-method) () |
| 107 | (:documentation "Effective method counterpart to `aggregating-message'.")) |
| 108 | |
| 109 | ;;;-------------------------------------------------------------------------- |
| 110 | ;;; Implementation. |
| 111 | |
| 112 | (defmethod check-message-type ((message aggregating-message) type) |
| 113 | (with-slots (combination) message |
| 114 | (check-aggregating-message-type message combination type))) |
| 115 | |
| 116 | (defmethod sod-message-effective-method-class ((message aggregating-message)) |
| 117 | 'aggregating-effective-method) |
| 118 | |
| 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))) |
| 125 | |
| 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))) |
| 132 | |
| 133 | ;; Check that we've been given a method combination and make sure it |
| 134 | ;; actually exists. |
| 135 | (unless comb |
| 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) |
| 145 | comb)))) |
| 146 | (generic-function-methods |
| 147 | #'compute-aggregating-message-kernel)) |
| 148 | (error "Unknown method combination `~(~A~)'." comb)) |
| 149 | (setf combination comb) |
| 150 | |
| 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'.")) |
| 154 | |
| 155 | ;; Set up the function which will compute the kernel. |
| 156 | (let ((magic (cons nil nil)) |
| 157 | (keys nil)) |
| 158 | |
| 159 | ;; Collect the property values wanted by the method combination. |
| 160 | (do ((want (aggregating-message-properties message comb) |
| 161 | (cddr want))) |
| 162 | ((endp want)) |
| 163 | (let* ((name (car want)) |
| 164 | (type (cadr want)) |
| 165 | (prop (get-property pset name type magic))) |
| 166 | (unless (eq prop magic) |
| 167 | (setf keys (list* name prop keys))))) |
| 168 | (setf plist keys) |
| 169 | |
| 170 | ;; Set the kernel function for later. |
| 171 | (setf kernel-function |
| 172 | (lambda (codegen target arg-names methods) |
| 173 | (apply #'compute-aggregating-message-kernel |
| 174 | message comb |
| 175 | codegen target |
| 176 | (ecase most-specific |
| 177 | (:first methods) |
| 178 | (:last (setf methods (reverse methods)))) |
| 179 | arg-names |
| 180 | plist))))))) |
| 181 | |
| 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))) |
| 190 | |
| 191 | ;;;-------------------------------------------------------------------------- |
| 192 | ;;; Utilities. |
| 193 | |
| 194 | (export 'define-aggregating-method-combination) |
| 195 | (defmacro define-aggregating-method-combination |
| 196 | (comb |
| 197 | (vars |
| 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. |
| 205 | |
| 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: |
| 209 | |
| 210 | * CODEGEN is the `codegen' object passed at effective-method computation |
| 211 | time; and |
| 212 | |
| 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. |
| 217 | |
| 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 |
| 220 | |
| 221 | (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP]) |
| 222 | |
| 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 |
| 227 | bound. |
| 228 | |
| 229 | All of these variables, and the VARS, are available in the functions |
| 230 | described below. |
| 231 | |
| 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. |
| 235 | |
| 236 | The AROUND, FIRST-METHOD, and METHODS are function designators (probably |
| 237 | `lambda' forms) providing pieces of the aggregating behaviour. |
| 238 | |
| 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. |
| 243 | |
| 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.) |
| 253 | |
| 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'." |
| 257 | |
| 258 | (with-gensyms (type msg combvar target arg-names args want-type |
| 259 | meth targ func call-methfunc |
| 260 | aroundfunc fmethfunc methfunc) |
| 261 | `(progn |
| 262 | |
| 263 | ;; If properties are listed, arrange for them to be collected. |
| 264 | ,@(and properties |
| 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 |
| 270 | (list name)))) |
| 271 | (if (cddr names) (car names) |
| 272 | (intern (car names) :keyword))) |
| 273 | (cadr prop))) |
| 274 | properties)))) |
| 275 | |
| 276 | ;; If a particular return type is wanted, check that. |
| 277 | ,@(and return-type |
| 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) |
| 284 | ,want-type) |
| 285 | (error "Messages with `~(~A~)' combination ~ |
| 286 | must return `~A'." |
| 287 | ,combvar ,want-type))) |
| 288 | (call-next-method)))) |
| 289 | |
| 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))) |
| 295 | properties)) |
| 296 | (declare (ignore ,combvar)) |
| 297 | |
| 298 | ;; Declare the necessary variables and give names to the functions |
| 299 | ;; supplied by the caller. |
| 300 | (let* (,@(and vars |
| 301 | `((,type (c-type-subtype (sod-message-type ,msg))))) |
| 302 | ,@(mapcar (lambda (var) |
| 303 | (list var `(temporary-var ,codegen ,type))) |
| 304 | vars) |
| 305 | (,aroundfunc ,around-func) |
| 306 | (,methfunc ,methods-func) |
| 307 | (,fmethfunc ,(if firstp first-method-func methfunc))) |
| 308 | |
| 309 | ;; Arrange to release the temporaries when we're finished with |
| 310 | ;; them. |
| 311 | (unwind-protect |
| 312 | (progn |
| 313 | |
| 314 | ;; Wrap the AROUND function around most of the work. |
| 315 | (funcall ,aroundfunc |
| 316 | (lambda (&rest ,args) |
| 317 | (flet ((,call-methfunc (,func ,meth) |
| 318 | ;; Call FUNC, passing it an INVOKE |
| 319 | ;; function which will generate a call |
| 320 | ;; to METH. |
| 321 | (apply ,func |
| 322 | (lambda |
| 323 | (&optional (,targ :void)) |
| 324 | (invoke-method ,codegen |
| 325 | ,targ |
| 326 | ,arg-names |
| 327 | ,meth)) |
| 328 | ,args))) |
| 329 | |
| 330 | ;; The first method might need special |
| 331 | ;; handling. |
| 332 | (,call-methfunc ,fmethfunc (car ,methods)) |
| 333 | |
| 334 | ;; Call the remaining methods in the right |
| 335 | ;; order. |
| 336 | (dolist (,meth (cdr ,methods)) |
| 337 | (,call-methfunc ,methfunc ,meth))))) |
| 338 | |
| 339 | ;; Outside the AROUND function now, deliver the final |
| 340 | ;; result to the right place. |
| 341 | (deliver-expr ,codegen ,target ,(car vars))) |
| 342 | |
| 343 | ;; Finally, release the temporary variables. |
| 344 | ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil)) |
| 345 | vars)))) |
| 346 | |
| 347 | ',comb))) |
| 348 | |
| 349 | ;;;-------------------------------------------------------------------------- |
| 350 | ;;; Fixed aggregating method combinations. |
| 351 | |
| 352 | (define-aggregating-method-combination :progn (nil) |
| 353 | :return-type void) |
| 354 | |
| 355 | (define-aggregating-method-combination :sum ((acc val) :codegen codegen) |
| 356 | :first-method (lambda (invoke) |
| 357 | (funcall invoke val) |
| 358 | (emit-inst codegen (make-set-inst acc val))) |
| 359 | :methods (lambda (invoke) |
| 360 | (funcall invoke val) |
| 361 | (emit-inst codegen (make-update-inst acc #\+ val)))) |
| 362 | |
| 363 | (define-aggregating-method-combination :product ((acc val) :codegen codegen) |
| 364 | :first-method (lambda (invoke) |
| 365 | (funcall invoke val) |
| 366 | (emit-inst codegen (make-set-inst acc val))) |
| 367 | :methods (lambda (invoke) |
| 368 | (funcall invoke val) |
| 369 | (emit-inst codegen (make-update-inst acc #\* val)))) |
| 370 | |
| 371 | (define-aggregating-method-combination :min ((acc val) :codegen codegen) |
| 372 | :first-method (lambda (invoke) |
| 373 | (funcall invoke val) |
| 374 | (emit-inst codegen (make-set-inst acc val))) |
| 375 | :methods (lambda (invoke) |
| 376 | (funcall invoke val) |
| 377 | (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val) |
| 378 | (make-set-inst acc val))))) |
| 379 | |
| 380 | (define-aggregating-method-combination :max ((acc val) :codegen codegen) |
| 381 | :first-method (lambda (invoke) |
| 382 | (funcall invoke val) |
| 383 | (emit-inst codegen (make-set-inst acc val))) |
| 384 | :methods (lambda (invoke) |
| 385 | (funcall invoke val) |
| 386 | (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val) |
| 387 | (make-set-inst acc val))))) |
| 388 | |
| 389 | (define-aggregating-method-combination :and ((ret) :codegen codegen) |
| 390 | :around (lambda (body) |
| 391 | (codegen-push codegen) |
| 392 | (funcall body) |
| 393 | (emit-inst codegen |
| 394 | (make-do-while-inst (codegen-pop-block codegen) 0))) |
| 395 | :methods (lambda (invoke) |
| 396 | (funcall invoke ret) |
| 397 | (emit-inst codegen (make-if-inst (format nil "!~A" ret) |
| 398 | (make-break-inst))))) |
| 399 | |
| 400 | (define-aggregating-method-combination :or ((ret) :codegen codegen) |
| 401 | :around (lambda (body) |
| 402 | (codegen-push codegen) |
| 403 | (funcall body) |
| 404 | (emit-inst codegen |
| 405 | (make-do-while-inst (codegen-pop-block codegen) 0))) |
| 406 | :methods (lambda (invoke) |
| 407 | (funcall invoke ret) |
| 408 | (emit-inst codegen (make-if-inst ret (make-break-inst))))) |
| 409 | |
| 410 | ;;;-------------------------------------------------------------------------- |
| 411 | ;;; A customizable aggregating method combination. |
| 412 | |
| 413 | (defmethod aggregating-message-properties |
| 414 | ((message aggregating-message) (combination (eql :custom))) |
| 415 | '(:retvar :id |
| 416 | :valvar :id |
| 417 | :methty :type |
| 418 | :decls :fragment |
| 419 | :before :fragment |
| 420 | :first :fragment |
| 421 | :each :fragment |
| 422 | :after :fragment |
| 423 | :count :id)) |
| 424 | |
| 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)))) |
| 429 | |
| 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)) |
| 441 | (when count |
| 442 | (ensure-var codegen count c-type-size-t (length methods))) |
| 443 | (when decls |
| 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) |
| 450 | arg-names method) |
| 451 | (maybe-emit fragment))) |
| 452 | (maybe-emit before) |
| 453 | (invoke (car methods) first) |
| 454 | (dolist (method (cdr methods)) (invoke method each)) |
| 455 | (maybe-emit after) |
| 456 | (deliver-expr codegen target retvar)))) |
| 457 | |
| 458 | ;;;----- That's all, folks -------------------------------------------------- |