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