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 (defgeneric aggregating-message-always-live-p (message combination)
 110   (:documentation
 111    "Return whether the method combination can work without primary methods.
 112
 113    Return non-nil if the corresponding effective method should be considered
 114    live even if it doesn't have any methods.")
 115   (:method ((message aggregating-message) (combination t)) nil))
 116
 117 (defmethod effective-method-live-p ((method aggregating-effective-method))
 118   (or (let* ((message (effective-method-message method))
 119              (comb (sod-message-combination message)))
 120         (aggregating-message-always-live-p message comb))
 121       (call-next-method)))
 122
 123 ;;;--------------------------------------------------------------------------
 124 ;;; Implementation.
 125
 126 (defmethod check-message-type ((message aggregating-message) type)
 127   (with-slots (combination) message
 128     (check-aggregating-message-type message combination type)))
 129
 130 (defmethod sod-message-effective-method-class ((message aggregating-message))
 131   'aggregating-effective-method)
 132
 133 (defmethod simple-method-body
 134     ((method aggregating-effective-method) codegen target)
 135   (let ((argument-names (effective-method-basic-argument-names method))
 136         (primary-methods (effective-method-primary-methods method)))
 137     (funcall (sod-message-kernel-function (effective-method-message method))
 138              codegen target argument-names primary-methods)))
 139
 140 (defmethod shared-initialize :before
 141     ((message aggregating-message) slot-names &key pset)
 142   (declare (ignore slot-names))
 143   (with-slots (combination plist kernel-function) message
 144     (let ((most-specific (get-property pset :most-specific :keyword :first))
 145           (comb (get-property pset :combination :keyword)))
 146
 147       ;; Check that we've been given a method combination and make sure it
 148       ;; actually exists.
 149       (unless comb
 150         (error "The `combination' property is required."))
 151       (unless (some (lambda (method)
 152                       (let* ((specs (method-specializers method))
 153                              (message-spec (car specs))
 154                              (combination-spec (cadr specs)))
 155                         (and (typep message-spec 'class)
 156                              (typep message message-spec)
 157                              (typep combination-spec 'eql-specializer)
 158                              (eq (eql-specializer-object combination-spec)
 159                                  comb))))
 160                     (generic-function-methods
 161                      #'compute-aggregating-message-kernel))
 162         (error "Unknown method combination `~(~A~)'." comb))
 163       (setf combination comb)
 164
 165       ;; Make sure the ordering is actually valid.
 166       (unless (member most-specific '(:first :last))
 167         (error "The `most_specific' property must be `first' or `last'."))
 168
 169       ;; Set up the function which will compute the kernel.
 170       (let ((magic (cons nil nil))
 171             (keys nil))
 172
 173         ;; Collect the property values wanted by the method combination.
 174         (do ((want (aggregating-message-properties message comb)
 175                    (cddr want)))
 176             ((endp want))
 177           (let* ((name (car want))
 178                  (type (cadr want))
 179                  (prop (get-property pset name type magic)))
 180             (unless (eq prop magic)
 181               (setf keys (list* name prop keys)))))
 182         (setf plist keys)
 183
 184         ;; Set the kernel function for later.
 185         (setf kernel-function
 186               (lambda (codegen target arg-names methods)
 187                 (apply #'compute-aggregating-message-kernel
 188                        message comb
 189                        codegen target
 190                        (ecase most-specific
 191                          (:first methods)
 192                          (:last (setf methods (reverse methods))))
 193                        arg-names
 194                        plist)))))))
 195
 196 (defmethod check-method-type
 197     ((method sod-method) (message aggregating-message)
 198      (type c-function-type))
 199   (let ((wanted (aggregating-message-method-return-type
 200                  message (sod-message-combination message)))
 201         (msgtype (sod-message-type message)))
 202     (check-method-return-type type wanted)
 203     (check-method-argument-lists type msgtype)))
 204
 205 ;;;--------------------------------------------------------------------------
 206 ;;; Utilities.
 207
 208 (export 'define-aggregating-method-combination)
 209 (defmacro define-aggregating-method-combination
 210     (comb
 211      (vars
 212       &key (codegen (gensym "CODEGEN-"))
 213            (methods (gensym "METHODS-")))
 214      &key properties return-type
 215           ((:around around-func) '#'funcall)
 216           ((:empty empty-func) nil emptyp)
 217           ((:first-method first-method-func) nil firstp)
 218           ((:methods methods-func) '#'funcall))
 219   "Utility macro for definining aggregating method combinations.
 220
 221    The VARS are a list of variable names to be bound to temporary variable
 222    objects of the method's return type.  Additional keyword arguments define
 223    variables names to be bound to other possibly interesting values:
 224
 225      * CODEGEN is the `codegen' object passed at effective-method computation
 226        time; and
 227
 228      * METHODS is the list of primary methods, in the order in which they
 229        should be invoked.  Note that this list must be non-empty, since
 230        otherwise the method on `compute-effective-method-body' specialized to
 231        `simple-effective-method' will suppress the method entirely.
 232
 233    The PROPERTIES, if specified, are a list of properties to be collected
 234    during message-object initialization; items in the list have the form
 235
 236            (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
 237
 238    similar to a `&key' BVL entry, except for the additional TYPE entry.  In
 239    particular, a symbolic NAME may be written in place of a singleton list.
 240    The KEYWORD names the property as it should be looked up in the pset,
 241    while the NAME names a variable to which the property value or default is
 242    bound.
 243
 244    All of these variables, and the VARS, are available in the functions
 245    described below.
 246
 247    If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
 248    on `check-aggregating-message-type' to check the that the message's return
 249    type matches RETURN-TYPE.
 250
 251    If an EMPTY function is given, then (a) it's OK if there are no primary
 252    methods, because (b) the EMPTY function is called to set the return
 253    value variable in this case.  Note that EMPTY is only called when there
 254    are no primary methods.
 255
 256    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
 257    `lambda' forms) providing pieces of the aggregating behaviour.
 258
 259    The AROUND function is called first, with a single argument BODY, though
 260    the variables above are also in scope.  It is expected to emit code to
 261    CODEGEN which invokes the METHODS in the appropriate order, and arranges
 262    to store the aggregated return value in the first of the VARS.
 263
 264    It may call BODY as a function in order to assist with this; let ARGS be
 265    the list of arguments supplied to it.  The default behaviour is to call
 266    BODY with no arguments.  The BODY function first calls FIRST-METHOD,
 267    passing it as arguments a function INVOKE and the ARGS which were passed
 268    to BODY, and then calls METHODS once for each remaining method, again
 269    passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
 270    specified, then the METHODS function is used for all of the methods.  If
 271    METHODS is not specified, then the behaviour is simply to call INVOKE
 272    immediately.  (See the definition of the `:progn' method combination.)
 273
 274    Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
 275    the appropriate direct method and deliver its return value to TARGET,
 276    which defaults to `:void'."
 277
 278   (with-gensyms (type msg combvar target arg-names args want-type
 279                  meth targ func call-methfunc
 280                  aroundfunc fmethfunc methfunc bodyfunc)
 281     `(progn
 282
 283        ;; If properties are listed, arrange for them to be collected.
 284        ,@(and properties
 285               `((defmethod aggregating-message-properties
 286                     ((,msg aggregating-message) (,combvar (eql ',comb)))
 287                   ',(mapcan (lambda (prop)
 288                               (list (let* ((name (car prop))
 289                                            (names (if (listp name) name
 290                                                       (list name))))
 291                                       (if (cddr names) (car names)
 292                                           (intern (car names) :keyword)))
 293                                     (cadr prop)))
 294                             properties))))
 295
 296        ;; If a particular return type is wanted, check that.
 297        ,@(and return-type
 298               `((defmethod check-aggregating-message-type
 299                     ((,msg aggregating-message)
 300                      (,combvar (eql ',comb))
 301                      (,type c-function-type))
 302                   (let ((,want-type (c-type ,return-type)))
 303                     (unless (c-type-equal-p (c-type-subtype ,type)
 304                                             ,want-type)
 305                       (error "Messages with `~(~A~)' combination ~
 306                               must return `~A'."
 307                              ,combvar ,want-type)))
 308                   (call-next-method))))
 309
 310        ;; If there is an EMPTY function then the effective method is always
 311        ;; live.
 312        ,@(and emptyp
 313               `((defmethod aggregating-message-always-live-p
 314                     ((,msg aggregating-message)
 315                      (,combvar (eql ',comb)))
 316                   t)))
 317
 318        ;; Define the main kernel-compuation method.
 319        (defmethod compute-aggregating-message-kernel
 320            ((,msg aggregating-message) (,combvar (eql ',comb))
 321             ,codegen ,target ,methods ,arg-names
 322             &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
 323                            properties))
 324          (declare (ignore ,combvar))
 325
 326          ;; Declare the necessary variables and give names to the functions
 327          ;; supplied by the caller.
 328          (let* (,@(and vars
 329                        `((,type (c-type-subtype (sod-message-type ,msg)))
 330                          (,(car vars) (temporary-var ,codegen ,type))))
 331                 ,@(mapcar (lambda (var)
 332                             (list var `(and ,methods
 333                                             (temporary-var ,codegen ,type))))
 334                           (cdr vars))
 335                 (,aroundfunc ,around-func)
 336                 (,methfunc ,methods-func)
 337                 (,fmethfunc ,(if firstp first-method-func methfunc)))
 338
 339            (flet ((,bodyfunc ()
 340                     (funcall ,aroundfunc
 341                              (lambda (&rest ,args)
 342                                (flet ((,call-methfunc (,func ,meth)
 343                                         ;; Call FUNC, passing it an INVOKE
 344                                         ;; function which will generate a
 345                                         ;; call to METH.
 346                                         (apply ,func
 347                                                (lambda
 348                                                    (&optional (,targ :void))
 349                                                  (invoke-method ,codegen
 350                                                                 ,targ
 351                                                                 ,arg-names
 352                                                                 ,meth))
 353                                                ,args)))
 354
 355                                  ;; The first method might need special
 356                                  ;; handling.
 357                                  (,call-methfunc ,fmethfunc (car ,methods))
 358
 359                                  ;; Call the remaining methods in the right
 360                                  ;; order.
 361                                  (dolist (,meth (cdr ,methods))
 362                                    (,call-methfunc ,methfunc ,meth)))))))
 363
 364              ;; Arrange to release the temporaries when we're finished with
 365              ;; them.
 366              (unwind-protect
 367                   (progn
 368
 369                     ;; If there are no direct methods, then just do the
 370                     ;; empty-effective-method thing to set the return
 371                     ;; variable.  Otherwise, wrap AROUND round the main body.
 372                     ,(if emptyp
 373                          `(if (null ,methods)
 374                               (funcall ,empty-func)
 375                               (,bodyfunc))
 376                          `(,bodyfunc))
 377
 378                   ;; Outside the AROUND function now, deliver the final
 379                   ;; result to the right place.
 380                   (deliver-expr ,codegen ,target ,(car vars)))
 381
 382                ;; Finally, release the temporary variables.
 383                ,@(mapcar (lambda (var)
 384                            `(when ,var (setf (var-in-use-p ,var) nil)))
 385                          vars)))))
 386
 387        ',comb)))
 388
 389 ;;;--------------------------------------------------------------------------
 390 ;;; Fixed aggregating method combinations.
 391
 392 (define-aggregating-method-combination :progn (nil)
 393   :return-type void
 394   :empty (lambda () nil))
 395
 396 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
 397   :empty (lambda () (emit-inst codegen (make-set-inst acc 0)))
 398   :first-method (lambda (invoke)
 399                   (funcall invoke val)
 400                   (emit-inst codegen (make-set-inst acc val)))
 401   :methods (lambda (invoke)
 402              (funcall invoke val)
 403              (emit-inst codegen (make-update-inst acc #\+ val))))
 404
 405 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
 406   :empty (lambda () (emit-inst codegen (make-set-inst acc 1)))
 407   :first-method (lambda (invoke)
 408                   (funcall invoke val)
 409                   (emit-inst codegen (make-set-inst acc val)))
 410   :methods (lambda (invoke)
 411              (funcall invoke val)
 412              (emit-inst codegen (make-update-inst acc #\* val))))
 413
 414 (define-aggregating-method-combination :min ((acc val) :codegen codegen)
 415   :first-method (lambda (invoke)
 416                   (funcall invoke val)
 417                   (emit-inst codegen (make-set-inst acc val)))
 418   :methods (lambda (invoke)
 419              (funcall invoke val)
 420              (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
 421                                               (make-set-inst acc val)))))
 422
 423 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
 424   :first-method (lambda (invoke)
 425                   (funcall invoke val)
 426                   (emit-inst codegen (make-set-inst acc val)))
 427   :methods (lambda (invoke)
 428              (funcall invoke val)
 429              (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
 430                                               (make-set-inst acc val)))))
 431
 432 (define-aggregating-method-combination :and ((ret) :codegen codegen)
 433   :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))
 434   :around (lambda (body)
 435             (codegen-push codegen)
 436             (funcall body)
 437             (emit-inst codegen
 438                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 439   :methods (lambda (invoke)
 440              (funcall invoke ret)
 441              (emit-inst codegen (make-if-inst (format nil "!~A" ret)
 442                                               (make-break-inst)))))
 443
 444 (define-aggregating-method-combination :or ((ret) :codegen codegen)
 445   :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))
 446   :around (lambda (body)
 447             (codegen-push codegen)
 448             (funcall body)
 449             (emit-inst codegen
 450                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 451   :methods (lambda (invoke)
 452              (funcall invoke ret)
 453              (emit-inst codegen (make-if-inst ret (make-break-inst)))))
 454
 455 ;;;--------------------------------------------------------------------------
 456 ;;; A customizable aggregating method combination.
 457
 458 (defmethod aggregating-message-properties
 459     ((message aggregating-message) (combination (eql :custom)))
 460   '(:retvar :id
 461     :valvar :id
 462     :methty :type
 463     :empty :fragment
 464     :decls :fragment
 465     :before :fragment
 466     :first :fragment
 467     :each :fragment
 468     :after :fragment
 469     :count :id))
 470
 471 (defmethod aggregating-message-method-return-type
 472     ((message aggregating-message) (combination (eql :custom)))
 473   (getf (sod-message-plist message) :methty
 474         (c-type-subtype (sod-message-type message))))
 475
 476 (defmethod aggregating-message-always-live-p
 477     ((message aggregating-message) (combination (eql :custom)))
 478   (getf (sod-message-plist message) :empty))
 479
 480 (defmethod compute-aggregating-message-kernel
 481     ((message aggregating-message) (combination (eql :custom))
 482      codegen target methods arg-names
 483      &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
 484           empty decls before each (first each) after count)
 485   (let* ((type (c-type-subtype (sod-message-type message)))
 486          (methty (if methtyp methty type)))
 487     (unless (eq type c-type-void)
 488       (ensure-var codegen retvar type))
 489     (unless (or (null methods)
 490                 (eq methty c-type-void))
 491       (ensure-var codegen valvar methty))
 492     (when (and methods count)
 493       (ensure-var codegen count c-type-size-t (length methods)))
 494     (when (and methods decls)
 495       (emit-decl codegen decls))
 496     (labels ((maybe-emit (fragment)
 497                (when fragment (emit-inst codegen fragment)))
 498              (invoke (method fragment)
 499                (invoke-method codegen
 500                               (if (eq methty c-type-void) :void valvar)
 501                               arg-names method)
 502                (maybe-emit fragment)))
 503       (cond ((and empty (null methods))
 504              (emit-inst codegen empty))
 505             (t
 506              (maybe-emit before)
 507              (invoke (car methods) first)
 508              (dolist (method (cdr methods)) (invoke method each))
 509              (maybe-emit after)))
 510       (deliver-expr codegen target retvar))))
 511
 512 ;;;----- That's all, folks --------------------------------------------------