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 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     (unless (c-type-equal-p (c-type-subtype type) wanted)
 189       (error "Method return type ~A doesn't match message ~A"
 190               (c-type-subtype msgtype) (c-type-subtype type)))
 191     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 192                                          (c-function-arguments type))
 193       (error "Method arguments ~A don't match message ~A" type msgtype))))
 194
 195 ;;;--------------------------------------------------------------------------
 196 ;;; Utilities.
 197
 198 (export 'define-aggregating-method-combination)
 199 (defmacro define-aggregating-method-combination
 200     (comb
 201      (vars
 202       &key (codegen (gensym "CODEGEN-"))
 203            (methods (gensym "METHODS-")))
 204      &key properties return-type
 205           ((:around around-func) '#'funcall)
 206           ((:first-method first-method-func) nil firstp)
 207           ((:methods methods-func) '#'funcall))
 208   "Utility macro for definining aggregating method combinations.
 209
 210    The VARS are a list of variable names to be bound to temporary variable
 211    objects of the method's return type.  Additional keyword arguments define
 212    variables names to be bound to other possibly interesting values:
 213
 214      * CODEGEN is the `codegen' object passed at effective-method computation
 215        time; and
 216
 217      * METHODS is the list of primary methods, in the order in which they
 218        should be invoked.  Note that this list must be non-empty, since
 219        otherwise the method on `compute-effective-method-body' specialized to
 220        `simple-effective-method' will suppress the method entirely.
 221
 222    The PROPERTIES, if specified, are a list of properties to be collected
 223    during message-object initialization; items in the list have the form
 224
 225            (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
 226
 227    similar to a `&key' BVL entry, except for the additional TYPE entry.  In
 228    particular, a symbolic NAME may be written in place of a singleton list.
 229    The KEYWORD names the property as it should be looked up in the pset,
 230    while the NAME names a variable to which the property value or default is
 231    bound.
 232
 233    All of these variables, and the VARS, are available in the functions
 234    described below.
 235
 236    If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
 237    on `check-aggregating-message-type' to check the that the message's return
 238    type matches RETURN-TYPE.
 239
 240    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
 241    `lambda' forms) providing pieces of the aggregating behaviour.
 242
 243    The AROUND function is called first, with a single argument BODY, though
 244    the variables above are also in scope.  It is expected to emit code to
 245    CODEGEN which invokes the METHODS in the appropriate order, and arranges
 246    to store the aggregated return value in the first of the VARS.
 247
 248    It may call BODY as a function in order to assist with this; let ARGS be
 249    the list of arguments supplied to it.  The default behaviour is to call
 250    BODY with no arguments.  The BODY function first calls FIRST-METHOD,
 251    passing it as arguments a function INVOKE and the ARGS which were passed
 252    to BODY, and then calls METHODS once for each remaining method, again
 253    passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
 254    specified, then the METHODS function is used for all of the methods.  If
 255    METHODS is not specified, then the behaviour is simply to call INVOKE
 256    immediately.  (See the definition of the `:progn' method combination.)
 257
 258    Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
 259    the appropriate direct method and deliver its return value to TARGET,
 260    which defaults to `:void'."
 261
 262   (with-gensyms (type msg combvar target arg-names args want-type
 263                  meth targ func call-methfunc
 264                  aroundfunc fmethfunc methfunc)
 265     `(progn
 266
 267        ;; If properties are listed, arrange for them to be collected.
 268        ,@(and properties
 269               `((defmethod aggregating-message-properties
 270                     ((,msg aggregating-message) (,combvar (eql ',comb)))
 271                   ',(mapcan (lambda (prop)
 272                               (list (let* ((name (car prop))
 273                                            (names (if (listp name) name
 274                                                       (list name))))
 275                                       (if (cddr names) (car names)
 276                                           (intern (car names) :keyword)))
 277                                     (cadr prop)))
 278                             properties))))
 279
 280        ;; If a particular return type is wanted, check that.
 281        ,@(and return-type
 282               `((defmethod check-aggregating-message-type
 283                     ((,msg aggregating-message)
 284                      (,combvar (eql ',comb))
 285                      (,type c-function-type))
 286                   (let ((,want-type (c-type ,return-type)))
 287                     (unless (c-type-equal-p (c-type-subtype ,type)
 288                                             ,want-type)
 289                       (error "Messages with `~(~A~)' combination ~
 290                               must return `~A'."
 291                              ,combvar ,want-type)))
 292                   (call-next-method))))
 293
 294        ;; Define the main kernel-compuation method.
 295        (defmethod compute-aggregating-message-kernel
 296            ((,msg aggregating-message) (,combvar (eql ',comb))
 297             ,codegen ,target ,methods ,arg-names
 298             &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
 299                            properties))
 300          (declare (ignore ,combvar))
 301
 302          ;; Declare the necessary variables and give names to the functions
 303          ;; supplied by the caller.
 304          (let* (,@(and vars
 305                        `((,type (c-type-subtype (sod-message-type ,msg)))))
 306                 ,@(mapcar (lambda (var)
 307                             (list var `(temporary-var ,codegen ,type)))
 308                           vars)
 309                 (,aroundfunc ,around-func)
 310                 (,methfunc ,methods-func)
 311                 (,fmethfunc ,(if firstp first-method-func methfunc)))
 312
 313            ;; Arrange to release the temporaries when we're finished with
 314            ;; them.
 315            (unwind-protect
 316                 (progn
 317
 318                   ;; Wrap the AROUND function around most of the work.
 319                   (funcall ,aroundfunc
 320                            (lambda (&rest ,args)
 321                              (flet ((,call-methfunc (,func ,meth)
 322                                       ;; Call FUNC, passing it an INVOKE
 323                                       ;; function which will generate a call
 324                                       ;; to METH.
 325                                       (apply ,func
 326                                              (lambda
 327                                                  (&optional (,targ :void))
 328                                                (invoke-method ,codegen
 329                                                               ,targ
 330                                                               ,arg-names
 331                                                               ,meth))
 332                                              ,args)))
 333
 334                                ;; The first method might need special
 335                                ;; handling.
 336                                (,call-methfunc ,fmethfunc (car ,methods))
 337
 338                                ;; Call the remaining methods in the right
 339                                ;; order.
 340                                (dolist (,meth (cdr ,methods))
 341                                  (,call-methfunc ,methfunc ,meth)))))
 342
 343                   ;; Outside the AROUND function now, deliver the final
 344                   ;; result to the right place.
 345                   (deliver-expr ,codegen ,target ,(car vars)))
 346
 347              ;; Finally, release the temporary variables.
 348              ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
 349                        vars))))
 350
 351        ',comb)))
 352
 353 ;;;--------------------------------------------------------------------------
 354 ;;; Fixed aggregating method combinations.
 355
 356 (define-aggregating-method-combination :progn (nil)
 357   :return-type void)
 358
 359 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
 360   :first-method (lambda (invoke)
 361                   (funcall invoke val)
 362                   (emit-inst codegen (make-set-inst acc val)))
 363   :methods (lambda (invoke)
 364              (funcall invoke val)
 365              (emit-inst codegen (make-update-inst acc #\+ val))))
 366
 367 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
 368   :first-method (lambda (invoke)
 369                   (funcall invoke val)
 370                   (emit-inst codegen (make-set-inst acc val)))
 371   :methods (lambda (invoke)
 372              (funcall invoke val)
 373              (emit-inst codegen (make-update-inst acc #\* val))))
 374
 375 (define-aggregating-method-combination :min ((acc val) :codegen codegen)
 376   :first-method (lambda (invoke)
 377                   (funcall invoke val)
 378                   (emit-inst codegen (make-set-inst acc val)))
 379   :methods (lambda (invoke)
 380              (funcall invoke val)
 381              (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
 382                                               (make-set-inst acc val)))))
 383
 384 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
 385   :first-method (lambda (invoke)
 386                   (funcall invoke val)
 387                   (emit-inst codegen (make-set-inst acc val)))
 388   :methods (lambda (invoke)
 389              (funcall invoke val)
 390              (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
 391                                               (make-set-inst acc val)))))
 392
 393 (define-aggregating-method-combination :and ((ret) :codegen codegen)
 394   :around (lambda (body)
 395             (codegen-push codegen)
 396             (funcall body)
 397             (emit-inst codegen
 398                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 399   :methods (lambda (invoke)
 400              (funcall invoke ret)
 401              (emit-inst codegen (make-if-inst (format nil "!~A" ret)
 402                                               (make-break-inst)))))
 403
 404 (define-aggregating-method-combination :or ((ret) :codegen codegen)
 405   :around (lambda (body)
 406             (codegen-push codegen)
 407             (funcall body)
 408             (emit-inst codegen
 409                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 410   :methods (lambda (invoke)
 411              (funcall invoke ret)
 412              (emit-inst codegen (make-if-inst ret (make-break-inst)))))
 413
 414 ;;;--------------------------------------------------------------------------
 415 ;;; A customizable aggregating method combination.
 416
 417 (defmethod aggregating-message-properties
 418     ((message aggregating-message) (combination (eql :custom)))
 419   '(:retvar :id
 420     :valvar :id
 421     :methty :type
 422     :decls :fragment
 423     :before :fragment
 424     :first :fragment
 425     :each :fragment
 426     :after :fragment
 427     :count :id))
 428
 429 (defmethod aggregating-message-method-return-type
 430     ((message aggregating-message) (combination (eql :custom)))
 431   (getf (sod-message-plist message) :methty
 432         (c-type-subtype (sod-message-type message))))
 433
 434 (defmethod compute-aggregating-message-kernel
 435     ((message aggregating-message) (combination (eql :custom))
 436      codegen target methods arg-names
 437      &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
 438           decls before each (first each) after count)
 439   (let* ((type (c-type-subtype (sod-message-type message)))
 440          (methty (if methtyp methty type)))
 441     (unless (eq type c-type-void)
 442       (ensure-var codegen retvar type))
 443     (unless (eq methty c-type-void)
 444       (ensure-var codegen valvar methty))
 445     (when count
 446       (ensure-var codegen count c-type-size-t (length methods)))
 447     (when decls
 448       (emit-decl codegen decls))
 449     (labels ((maybe-emit (fragment)
 450                (when fragment (emit-inst codegen fragment)))
 451              (invoke (method fragment)
 452                (invoke-method codegen
 453                               (if (eq methty c-type-void) :void valvar)
 454                               arg-names method)
 455                (maybe-emit fragment)))
 456       (maybe-emit before)
 457       (invoke (car methods) first)
 458       (dolist (method (cdr methods)) (invoke method each))
 459       (maybe-emit after)
 460       (deliver-expr codegen target retvar))))
 461
 462 ;;;----- That's all, folks --------------------------------------------------