mdw@git.distorted.org.uk Git - sod/blob - src/method-aggregate.lisp

   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 Sensble 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    (kernel-function :type function :reader sod-message-kernel-function))
  37   (:documentation
  38    "Message class for aggregating method combinations.
  39
  40    An aggregating method combination invokes the primary methods in order,
  41    most-specific first, collecting their return values, and combining them
  42    together in some way to produce a result for the effective method as a
  43    whole.
  44
  45    Mostly, this is done by initializing an accumulator to some appropriate
  46    value, updating it with the result of each primary method in turn, and
  47    finally returning some appropriate output function of it.  The order is
  48    determined by the `:most-specific' property, which may have the value
  49    `:first' or `:last'.
  50
  51    The `progn' method combination is implemented as a slightly weird special
  52    case of an aggregating method combination with a trivial state.  More
  53    typical combinations are `:sum', `:product', `:min', `:max', `:and', and
  54    `:or'.  Finally, there's a `custom' combination which uses user-supplied
  55    code fragments to stitch everything together."))
  56
  57 (export 'aggregating-message-properties)
  58 (defgeneric aggregating-message-properties (message combination)
  59   (:documentation
  60    "Return a description of the properties needed by the method COMBINATION.
  61
  62    The description should be a plist of alternating property name and type
  63    keywords.  The named properties will be looked up in the pset supplied at
  64    initialization time, and supplied to `compute-aggregating-message-kernel'
  65    as keyword arguments.  Defaults can be supplied in method BVLs.
  66
  67    The default is not to capture any property values.
  68
  69    The reason for this is as not to retain the pset beyond message object
  70    initialization.")
  71   (:method (message combination) nil))
  72
  73 (export 'compute-aggregating-message-kernel)
  74 (defgeneric compute-aggregating-message-kernel
  75     (message combination codegen target methods arg-names &key)
  76   (:documentation
  77    "Determine how to aggregate the direct methods for an aggregating message.
  78
  79    The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
  80    METHODS): it should emit, to CODEGEN, an appropriate effective-method
  81    kernel which invokes the listed direct METHODS, in the appropriate order,
  82    collects and aggregates their values, and delivers to TARGET the final
  83    result of the method kernel.
  84
  85    The easy way to implement this method is to use the macro
  86    `define-aggregating-method-combination'."))
  87
  88 (export 'check-aggregating-message-type)
  89 (defgeneric check-aggregating-message-type (message combination type)
  90   (:documentation
  91    "Check that TYPE is an acceptable function TYPE for the COMBINATION.
  92
  93    For example, `progn' messages must return `void', while `and' and `or'
  94    messages must return `int'.")
  95   (:method (message combination type)
  96     t))
  97
  98 (export 'aggregating-effective-method)
  99 (defclass aggregating-effective-method (simple-effective-method) ()
 100   (:documentation "Effective method counterpart to `aggregating-message'."))
 101
 102 ;;;--------------------------------------------------------------------------
 103 ;;; Implementation.
 104
 105 (defmethod check-message-type ((message aggregating-message) type)
 106   (with-slots (combination) message
 107     (check-aggregating-message-type message combination type)))
 108
 109 (defmethod sod-message-effective-method-class ((message aggregating-message))
 110   'aggregating-effective-method)
 111
 112 (defmethod simple-method-body
 113     ((method aggregating-effective-method) codegen target)
 114   (let ((argument-names (effective-method-basic-argument-names method))
 115         (primary-methods (effective-method-primary-methods method)))
 116     (funcall (sod-message-kernel-function (effective-method-message method))
 117              codegen target argument-names primary-methods)))
 118
 119 (defmethod shared-initialize :before
 120     ((message aggregating-message) slot-names &key pset)
 121   (declare (ignore slot-names))
 122   (with-slots (combination kernel-function) message
 123     (let ((most-specific (get-property pset :most-specific :keyword :first))
 124           (comb (get-property pset :combination :keyword)))
 125
 126       ;; Check that we've been given a method combination and make sure it
 127       ;; actually exists.
 128       (unless comb
 129         (error "The `combination' property is required."))
 130       (unless (some (lambda (method)
 131                       (let* ((specs (method-specializers method))
 132                              (message-spec (car specs))
 133                              (combination-spec (cadr specs)))
 134                         (and (typep message-spec 'class)
 135                              (typep message message-spec)
 136                              (typep combination-spec 'eql-specializer)
 137                              (eq (eql-specializer-object combination-spec)
 138                                  comb))))
 139                     (generic-function-methods
 140                      #'compute-aggregating-message-kernel))
 141         (error "Unknown method combination `~(~A~)'." comb))
 142       (setf combination comb)
 143
 144       ;; Make sure the ordering is actually valid.
 145       (unless (member most-specific '(:first :last))
 146         (error "The `most_specific' property must be `first' or `last'."))
 147
 148       ;; Set up the function which will compute the kernel.
 149       (let ((magic (cons nil nil))
 150             (keys nil))
 151
 152         ;; Collect the property values wanted by the method combination.
 153         (do ((want (aggregating-message-properties message comb)
 154                    (cddr want)))
 155             ((endp want))
 156           (let* ((name (car want))
 157                  (type (cadr want))
 158                  (prop (get-property pset name type magic)))
 159             (unless (eq prop magic)
 160               (setf keys (list* name prop keys)))))
 161
 162         ;; Set the kernel function for later.
 163         (setf kernel-function
 164               (lambda (codegen target arg-names methods)
 165                 (apply #'compute-aggregating-message-kernel
 166                        message comb
 167                        codegen target
 168                        (ecase most-specific
 169                          (:first methods)
 170                          (:last (setf methods (reverse methods))))
 171                        arg-names
 172                        keys)))))))
 173
 174 ;;;--------------------------------------------------------------------------
 175 ;;; Utilities.
 176
 177 (export 'define-aggregating-method-combination)
 178 (defmacro define-aggregating-method-combination
 179     (comb
 180      (vars
 181       &key (codegen (gensym "CODEGEN-"))
 182            (methods (gensym "METHODS-")))
 183      &key properties return-type
 184           ((:around around-func) '#'funcall)
 185           ((:first-method first-method-func) nil firstp)
 186           ((:methods methods-func) '#'funcall))
 187   "Utility macro for definining aggregating method combinations.
 188
 189    The VARS are a list of variable names to be bound to temporary variable
 190    objects of the method's return type.  Additional keyword arguments define
 191    variables names to be bound to other possibly interesting values:
 192
 193      * CODEGEN is the `codegen' object passed at effective-method computation
 194        time; and
 195
 196      * METHODS is the list of primary methods, in the order in which they
 197        should be invoked.  Note that this list must be non-empty, since
 198        otherwise the method on `compute-effective-method-body' specialized to
 199        `simple-effective-method' will suppress the method entirely.
 200
 201    The PROPERTIES, if specified, are a list of properties to be collected
 202    during message-object initialization; items in the list have the form
 203
 204            (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
 205
 206    similar to a `&key' BVL entry, except for the additional TYPE entry.  In
 207    particular, a symbolic NAME may be written in place of a singleton list.
 208    The KEYWORD names the property as it should be looked up in the pset,
 209    while the NAME names a variable to which the property value or default is
 210    bound.
 211
 212    All of these variables, and the VARS, are available in the functions
 213    described below.
 214
 215    If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
 216    on `check-aggregating-message-type' to check the that the message's return
 217    type matches RETURN-TYPE.
 218
 219    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
 220    `lambda' forms) providing pieces of the aggregating behaviour.
 221
 222    The AROUND function is called first, with a single argument BODY, though
 223    the variables above are also in scope.  It is expected to emit code to
 224    CODEGEN which invokes the METHODS in the appropriate order, and arranges
 225    to store the aggregated return value in the first of the VARS.
 226
 227    It may call BODY as a function in order to assist with this; let ARGS be
 228    the list of arguments supplied to it.  The default behaviour is to call
 229    BODY with no arguments.  The BODY function first calls FIRST-METHOD,
 230    passing it as arguments a function INVOKE and the ARGS which were passed
 231    to BODY, and then calls METHODS once for each remaining method, again
 232    passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
 233    specified, then the METHODS function is used for all of the methods.  If
 234    METHODS is not specified, then the behaviour is simply to call INVOKE
 235    immediately.  (See the definition of the `:progn' method combination.)
 236
 237    Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
 238    the appropriate direct method and deliver its return value to TARGET,
 239    which defaults to `:void'."
 240
 241   (with-gensyms (type msg combvar target arg-names args want-type
 242                  meth targ func call-methfunc
 243                  aroundfunc fmethfunc methfunc)
 244     `(progn
 245
 246        ;; If properties are listed, arrange for them to be collected.
 247        ,@(and properties
 248               `((defmethod aggregating-message-properties
 249                     ((,msg aggregating-message) (,combvar (eql ',comb)))
 250                   ',(mapcan (lambda (prop)
 251                               (list (let* ((name (car prop))
 252                                            (names (if (listp name) name
 253                                                       (list name))))
 254                                       (if (cddr names) (car names)
 255                                           (intern (car names) :keyword)))
 256                                     (cadr prop)))
 257                             properties))))
 258
 259        ;; If a particular return type is wanted, check that.
 260        ,@(and return-type
 261               `((defmethod check-aggregating-message-type
 262                     ((,msg aggregating-message)
 263                      (,combvar (eql ',comb))
 264                      (,type c-function-type))
 265                   (let ((,want-type (c-type ,return-type)))
 266                     (unless (c-type-equal-p (c-type-subtype ,type)
 267                                             ,want-type)
 268                       (error "Messages with `~(~A~)' combination ~
 269                               must return `~A'."
 270                              ,combvar ,want-type)))
 271                   (call-next-method))))
 272
 273        ;; Define the main kernel-compuation method.
 274        (defmethod compute-aggregating-message-kernel
 275            ((,msg aggregating-message) (,combvar (eql ',comb))
 276             ,codegen ,target ,methods ,arg-names
 277             &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
 278                            properties))
 279          (declare (ignore ,combvar))
 280
 281          ;; Declare the necessary variables and give names to the functions
 282          ;; supplied by the caller.
 283          (let* (,@(and vars
 284                        `((,type (c-type-subtype (sod-message-type ,msg)))))
 285                 ,@(mapcar (lambda (var)
 286                             (list var `(temporary-var ,codegen ,type)))
 287                           vars)
 288                 (,aroundfunc ,around-func)
 289                 (,methfunc ,methods-func)
 290                 (,fmethfunc ,(if firstp first-method-func methfunc)))
 291
 292            ;; Arrange to release the temporaries when we're finished with
 293            ;; them.
 294            (unwind-protect
 295                 (progn
 296
 297                   ;; Wrap the AROUND function around most of the work.
 298                   (funcall ,aroundfunc
 299                            (lambda (&rest ,args)
 300                              (flet ((,call-methfunc (,func ,meth)
 301                                       ;; Call FUNC, passing it an INVOKE
 302                                       ;; function which will generate a call
 303                                       ;; to METH.
 304                                       (apply ,func
 305                                              (lambda
 306                                                  (&optional (,targ :void))
 307                                                (invoke-method ,codegen
 308                                                               ,targ
 309                                                               ,arg-names
 310                                                               ,meth))
 311                                              ,args)))
 312
 313                                ;; The first method might need special
 314                                ;; handling.
 315                                (,call-methfunc ,fmethfunc (car ,methods))
 316
 317                                ;; Call the remaining methods in the right
 318                                ;; order.
 319                                (dolist (,meth (cdr ,methods))
 320                                  (,call-methfunc ,methfunc ,meth)))))
 321
 322                   ;; Outside the AROUND function now, deliver the final
 323                   ;; result to the right place.
 324                   (deliver-expr ,codegen ,target ,(car vars)))
 325
 326              ;; Finally, release the temporary variables.
 327              ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
 328                        vars))))
 329
 330        ',comb)))
 331
 332 ;;;--------------------------------------------------------------------------
 333 ;;; Fixed aggregating method combinations.
 334
 335 (define-aggregating-method-combination :progn (nil)
 336   :return-type void)
 337
 338 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
 339   :first-method (lambda (invoke)
 340                   (funcall invoke val)
 341                   (emit-inst codegen (make-set-inst acc val)))
 342   :methods (lambda (invoke)
 343              (funcall invoke val)
 344              (emit-inst codegen (make-update-inst acc #\+ val))))
 345
 346 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
 347   :first-method (lambda (invoke)
 348                   (funcall invoke val)
 349                   (emit-inst codegen (make-set-inst acc val)))
 350   :methods (lambda (invoke)
 351              (funcall invoke val)
 352              (emit-inst codegen (make-update-inst acc #\* val))))
 353
 354 (define-aggregating-method-combination :min ((acc val) :codegen codegen)
 355   :first-method (lambda (invoke)
 356                   (funcall invoke val)
 357                   (emit-inst codegen (make-set-inst acc val)))
 358   :methods (lambda (invoke)
 359              (funcall invoke val)
 360              (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
 361                                               (make-set-inst acc val) nil))))
 362
 363 (define-aggregating-method-combination :max ((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-if-inst (format nil "~A < ~A" acc val)
 370                                               (make-set-inst acc val) nil))))
 371
 372 (define-aggregating-method-combination :and ((ret val) :codegen codegen)
 373   :return-type int
 374   :around (lambda (body)
 375             (codegen-push codegen)
 376             (deliver-expr codegen ret 0)
 377             (funcall body)
 378             (deliver-expr codegen ret 1)
 379             (emit-inst codegen
 380                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 381   :methods (lambda (invoke)
 382              (funcall invoke val)
 383              (emit-inst codegen (make-if-inst (format nil "!~A" val)
 384                                               (make-break-inst) nil))))
 385
 386 (define-aggregating-method-combination :or ((ret val) :codegen codegen)
 387   :return-type int
 388   :around (lambda (body)
 389             (codegen-push codegen)
 390             (deliver-expr codegen ret 1)
 391             (funcall body)
 392             (deliver-expr codegen ret 0)
 393             (emit-inst codegen
 394                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 395   :methods (lambda (invoke)
 396              (funcall invoke val)
 397              (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
 398
 399 ;;;--------------------------------------------------------------------------
 400 ;;; A customizable aggregating method combination.
 401
 402 (defmethod aggregating-message-properties
 403     ((message aggregating-message) (combination (eql :custom)))
 404   '(:retvar :id
 405     :valvar :id
 406     :decls :fragment
 407     :before :fragment
 408     :first :fragment
 409     :each :fragment
 410     :after :fragment
 411     :count :id))
 412
 413 (defmethod compute-aggregating-message-kernel
 414     ((message aggregating-message) (combination (eql :custom))
 415      codegen target methods arg-names
 416      &key (retvar "sod_ret") (valvar "sod_val")
 417           decls before each (first each) after count)
 418   (let* ((type (c-type-subtype (sod-message-type message)))
 419          (not-void-p (not (eq type c-type-void))))
 420     (when not-void-p
 421       (ensure-var codegen retvar type)
 422       (ensure-var codegen valvar type))
 423     (when count
 424       (ensure-var codegen count c-type-int (length methods)))
 425     (when decls
 426       (emit-decl codegen decls))
 427     (labels ((maybe-emit (fragment)
 428                (when fragment (emit-inst codegen fragment)))
 429              (invoke (method fragment)
 430                (invoke-method codegen (if not-void-p valvar :void)
 431                               arg-names method)
 432                (maybe-emit fragment)))
 433       (maybe-emit before)
 434       (invoke (car methods) first)
 435       (dolist (method (cdr methods)) (invoke method each))
 436       (maybe-emit after)
 437       (deliver-expr codegen target retvar))))
 438
 439 ;;;----- That's all, folks --------------------------------------------------