chiark - git - mdw - sod/blob - src/method-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Method combination implementation
   4 ;;;
   5 ;;; (c) 2009 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 ;;; Message classes.
  30
  31 (export 'basic-message)
  32 (defclass basic-message (sod-message)
  33   ((argument-tail :type list :reader sod-message-argument-tail)
  34    (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
  35   (:documentation
  36    "Base class for built-in message classes.
  37
  38    Provides the basic functionality for the built-in method combinations.
  39    This is a separate class so that `special effect' messages can avoid
  40    inheriting its default behaviour.
  41
  42    The function type protocol is implemented on `basic-message' using slot
  43    reader methods.  The actual values are computed on demand in methods
  44    defined on `slot-unbound'."))
  45
  46 (defmethod slot-unbound (class
  47                          (message basic-message)
  48                          (slot-name (eql 'argument-tail)))
  49   (declare (ignore class))
  50   (let ((seq 0))
  51     (setf (slot-value message 'argument-tail)
  52           (mapcar (lambda (arg)
  53                     (if (or (eq arg :ellipsis) (argument-name arg)) arg
  54                         (make-argument (make-instance 'temporary-argument
  55                                                       :tag (prog1 seq
  56                                                              (incf seq)))
  57                                        (argument-type arg))))
  58                   (c-function-arguments (sod-message-type message))))))
  59
  60 (defmethod slot-unbound (class
  61                          (message basic-message)
  62                          (slot-name (eql 'no-varargs-tail)))
  63   (declare (ignore class))
  64   (setf (slot-value message 'no-varargs-tail)
  65         (mapcar (lambda (arg)
  66                   (if (eq arg :ellipsis)
  67                       (make-argument *sod-ap* (c-type va-list))
  68                       arg))
  69                 (sod-message-argument-tail message))))
  70
  71 (defmethod sod-message-method-class
  72     ((message basic-message) (class sod-class) pset)
  73   (let ((role (get-property pset :role :keyword nil)))
  74     (case role
  75       ((:before :after) 'daemon-direct-method)
  76       (:around 'delegating-direct-method)
  77       ((nil) (error "How odd: a primary method slipped through the net"))
  78       (t (error "Unknown method role ~A" role)))))
  79
  80 (export 'simple-message)
  81 (defclass simple-message (basic-message)
  82   ()
  83   (:documentation
  84    "Base class for messages with `simple' method combinations.
  85
  86    A simple method combination is one which has only one method role other
  87    than the `before', `after' and `around' methods provided by
  88    `basic-message'.  We call these `primary' methods, and the programmer
  89    designates them by not specifying an explicit role.
  90
  91    If the programmer doesn't define any primary methods then the effective
  92    method is null -- i.e., the method entry pointer shows up as a null
  93    pointer."))
  94
  95 (defmethod sod-message-method-class
  96     ((message simple-message) (class sod-class) pset)
  97   (if (get-property pset :role :keyword nil)
  98       (call-next-method)
  99       (primary-method-class message)))
 100
 101 (defmethod primary-method-class ((message simple-message))
 102   'basic-direct-method)
 103
 104 ;;;--------------------------------------------------------------------------
 105 ;;; Direct method classes.
 106
 107 (export 'basic-direct-method)
 108 (defclass basic-direct-method (sod-method)
 109   ((role :initarg :role :type symbol :reader sod-method-role)
 110    (function-type :type c-function-type :reader sod-method-function-type))
 111   (:documentation
 112    "Base class for built-in direct method classes.
 113
 114    Provides the basic functionality for the built-in direct-method classes.
 115    This is a separate class so that `special effect' methods can avoid
 116    inheriting its default behaviour and slots.
 117
 118    A basic method can be assigned a `role', which may be set either as an
 119    initarg or using the `:role' property.  Roles are used for method
 120    categorization.
 121
 122    The function type protocol is implemented on `basic-direct-method' using
 123    slot reader methods.  The actual values are computed on demand in methods
 124    defined on `slot-unbound'."))
 125
 126 (defmethod shared-initialize :after
 127     ((method basic-direct-method) slot-names &key pset)
 128   (declare (ignore slot-names))
 129   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 130
 131 (defmethod slot-unbound
 132     (class (method basic-direct-method) (slot-name (eql 'function-type)))
 133   (declare (ignore class))
 134   (let ((type (sod-method-type method)))
 135     (setf (slot-value method 'function-type)
 136           (c-type (fun (lisp (c-type-subtype type))
 137                        ("me" (* (class (sod-method-class method))))
 138                        . (c-function-arguments type))))))
 139
 140 (defmethod sod-method-function-name ((method basic-direct-method))
 141   (with-slots (class role message) method
 142     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 143             (sod-class-nickname (sod-message-class message))
 144             (sod-message-name message))))
 145
 146 (export 'daemon-direct-method)
 147 (defclass daemon-direct-method (basic-direct-method)
 148   ()
 149   (:documentation
 150    "A daemon direct method is invoked for side effects and cannot override.
 151
 152    This is the direct method class for `before' and `after' methods, which
 153    cannot choose to override the remaining methods and are not involved in
 154    the computation of the final result.
 155
 156    In C terms, a daemon method must return `void', and is not passed a
 157    `next_method' pointer."))
 158
 159 (defmethod check-method-type ((method daemon-direct-method)
 160                               (message sod-message)
 161                               (type c-function-type))
 162   (with-slots ((msgtype type)) message
 163     (unless (c-type-equal-p (c-type-subtype type) (c-type void))
 164       (error "Method return type ~A must be `void'" (c-type-subtype type)))
 165     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 166                                          (c-function-arguments type))
 167       (error "Method arguments ~A don't match message ~A" type msgtype))))
 168
 169 (export 'delegating-direct-method)
 170 (defclass delegating-direct-method (basic-direct-method)
 171   ((next-method-type :type c-function-type
 172                      :reader sod-method-next-method-type))
 173   (:documentation
 174    "A delegating direct method can choose to override other methods.
 175
 176    This is the direct method class for `around' and standard-method-
 177    combination primary methods, which are given the choice of computing the
 178    entire method's result or delegating to (usually) less-specific methods.
 179
 180    In C terms, a delegating method is passed a `next_method' pointer so that
 181    it can delegate part of its behaviour.  (A delegating direct method for a
 182    varargs message is also given an additional `va_list' argument,
 183    conventionally named `sod__ap_master', which it is expected to pass on to
 184    its `next_method' function if necessary.)
 185
 186    The function type protocol is implemented on `delegating-direct-method'
 187    using slot reader methods.  The actual values are computed on demand in
 188    methods defined on `slot-unbound'."))
 189
 190 (defmethod slot-unbound (class
 191                          (method delegating-direct-method)
 192                          (slot-name (eql 'next-method-type)))
 193   (declare (ignore class))
 194   (let* ((message (sod-method-message method))
 195          (type (sod-message-type message)))
 196     (setf (slot-value method 'next-method-type)
 197           (c-type (fun (lisp (c-type-subtype type))
 198                        ("me" (* (class (sod-method-class method))))
 199                        .
 200                        (c-function-arguments type))))))
 201
 202 (defmethod slot-unbound (class
 203                          (method delegating-direct-method)
 204                          (slot-name (eql 'function-type)))
 205   (declare (ignore class))
 206   (let* ((message (sod-method-message method))
 207          (type (sod-method-type method))
 208          (method-args (c-function-arguments type)))
 209     (setf (slot-value method 'function-type)
 210           (c-type (fun (lisp (c-type-subtype type))
 211                        ("me" (* (class (sod-method-class method))))
 212                        ("next_method" (* (lisp (commentify-function-type
 213                                                 (sod-method-next-method-type
 214                                                  method)))))
 215                        .
 216                        (if (varargs-message-p message)
 217                            (cons (make-argument *sod-master-ap*
 218                                                 (c-type va-list))
 219                                  method-args)
 220                            method-args))))))
 221
 222 ;;;--------------------------------------------------------------------------
 223 ;;; Effective method classes.
 224
 225 (export 'basic-effective-method)
 226 (defclass basic-effective-method (effective-method)
 227   ((around-methods :initarg :around-methods :initform nil
 228                    :type list :reader effective-method-around-methods)
 229    (before-methods :initarg :before-methods :initform nil
 230                    :type list :reader effective-method-before-methods)
 231    (after-methods :initarg :after-methods :initform nil
 232                   :type list :reader effective-method-after-methods)
 233    (basic-argument-names :type list
 234                          :reader effective-method-basic-argument-names)
 235    (functions :type list :reader effective-method-functions))
 236   (:documentation
 237    "Base class for built-in effective method classes.
 238
 239    This class maintains lists of the applicable `before', `after' and
 240    `around' methods and provides behaviour for invoking these methods
 241    correctly.
 242
 243    The argument names protocol is implemented on `basic-effective-method'
 244    using a slot reader method.  The actual values are computed on demand in
 245    methods defined on `slot-unbound'."))
 246
 247 (defmethod slot-unbound (class
 248                          (method basic-effective-method)
 249                          (slot-name (eql 'basic-argument-names)))
 250   (declare (ignore class))
 251   (let ((message (effective-method-message method)))
 252     (setf (slot-value method 'basic-argument-names)
 253           (subst *sod-master-ap* *sod-ap*
 254                  (mapcar #'argument-name
 255                          (sod-message-no-varargs-tail message))))))
 256
 257 (defmethod effective-method-function-name ((method effective-method))
 258   (let* ((class (effective-method-class method))
 259          (message (effective-method-message method))
 260          (message-class (sod-message-class message)))
 261     (format nil "~A__emethod_~A__~A"
 262             class
 263             (sod-class-nickname message-class)
 264             (sod-message-name message))))
 265
 266 (defmethod slot-unbound
 267     (class (method basic-effective-method) (slot-name (eql 'functions)))
 268   (declare (ignore class))
 269   (setf (slot-value method 'functions)
 270         (compute-method-entry-functions method)))
 271
 272 (export 'simple-effective-method)
 273 (defclass simple-effective-method (basic-effective-method)
 274   ((primary-methods :initarg :primary-methods :initform nil
 275                     :type list :reader effective-method-primary-methods))
 276   (:documentation
 277    "Effective method counterpart to `simple-message'."))
 278
 279 (defmethod shared-initialize :after
 280     ((method simple-effective-method) slot-names &key direct-methods)
 281   (declare (ignore slot-names))
 282   (categorize (method direct-methods :bind ((role (sod-method-role method))))
 283       ((primary (null role))
 284        (before (eq role :before))
 285        (after (eq role :after))
 286        (around (eq role :around)))
 287     (with-slots (primary-methods before-methods after-methods around-methods)
 288         method
 289       (setf primary-methods primary
 290             before-methods before
 291             after-methods (reverse after)
 292             around-methods around))))
 293
 294 ;;;--------------------------------------------------------------------------
 295 ;;; Code generation.
 296
 297 (defmethod shared-initialize :after
 298     ((codegen method-codegen) slot-names &key)
 299   (declare (ignore slot-names))
 300   (with-slots (message target) codegen
 301     (setf target
 302           (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
 303               :void
 304               :return))))
 305
 306 ;;;--------------------------------------------------------------------------
 307 ;;; Invoking direct methods.
 308
 309 (export 'basic-effective-method-body)
 310 (defun basic-effective-method-body (codegen target method body)
 311   "Build the common method-invocation structure.
 312
 313    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 314    the `around' methods, from most- to least-specific.  If they all delegate,
 315    then the `before' methods are run, most-specific first; next, the
 316    instructions generated by BODY (invoked with a target argument); then, the
 317    `after' methods are run, least-specific first; and, finally, the value
 318    delivered by the BODY is returned to the `around' methods.  The result
 319    returned by the outermost `around' method -- or, if there are none,
 320    delivered by the BODY -- is finally delivered to the TARGET."
 321
 322   (with-slots (message class before-methods after-methods around-methods)
 323       method
 324     (let* ((message-type (sod-message-type message))
 325            (return-type (c-type-subtype message-type))
 326            (basic-tail (effective-method-basic-argument-names method)))
 327       (flet ((method-kernel (target)
 328                (dolist (before before-methods)
 329                  (invoke-method codegen :void basic-tail before))
 330                (if (null after-methods)
 331                    (funcall body target)
 332                    (convert-stmts codegen target return-type
 333                                   (lambda (target)
 334                                     (funcall body target)
 335                                     (dolist (after (reverse after-methods))
 336                                       (invoke-method codegen :void
 337                                                      basic-tail after)))))))
 338         (invoke-delegation-chain codegen target basic-tail
 339                                  around-methods #'method-kernel)))))
 340
 341 ;;;--------------------------------------------------------------------------
 342 ;;; Method entry points.
 343
 344 (defparameter *method-entry-inline-threshold* 200
 345   "Threshold below which effective method bodies are inlined into entries.
 346
 347    After the effective method body has been computed, we calculate its
 348    metric, multiply by the number of entries we need to generate, and compare
 349    it with this threshold.  If the metric is below the threshold then we
 350    fold the method body into the entry functions; otherwise we split the
 351    effective method out into its own function.")
 352
 353 (defmethod method-entry-function-name
 354     ((method effective-method) (chain-head sod-class))
 355   (let* ((class (effective-method-class method))
 356          (message (effective-method-message method))
 357          (message-class (sod-message-class message)))
 358     (if (or (not (slot-boundp method 'functions))
 359             (slot-value method 'functions))
 360         (format nil "~A__mentry_~A__~A__chain_~A"
 361                 class
 362                 (sod-class-nickname message-class)
 363                 (sod-message-name message)
 364                 (sod-class-nickname chain-head))
 365         0)))
 366
 367 (defmethod method-entry-function-type ((entry method-entry))
 368   (let* ((method (method-entry-effective-method entry))
 369          (message (effective-method-message method))
 370          (type (sod-message-type message)))
 371     (c-type (fun (lisp (c-type-subtype type))
 372                  ("me" (* (class (method-entry-chain-tail entry))))
 373                  . (sod-message-argument-tail message)))))
 374
 375 (defmethod make-method-entry ((method basic-effective-method)
 376                               (chain-head sod-class) (chain-tail sod-class))
 377   (make-instance 'method-entry
 378                  :method method
 379                  :chain-head chain-head
 380                  :chain-tail chain-tail))
 381
 382 (defmethod compute-method-entry-functions ((method basic-effective-method))
 383
 384   ;; OK, there's quite a lot of this, so hold tight.
 385   ;;
 386   ;; The first thing we need to do is find all of the related objects.  This
 387   ;; is a bit verbose but fairly straightforward.
 388   ;;
 389   ;; Next, we generate the effective method body -- using `compute-effective-
 390   ;; method-body' of all things.  This gives us the declarations and body for
 391   ;; an effective method function, but we don't have an actual function yet.
 392   ;;
 393   ;; Now we look at the chains which are actually going to need a method
 394   ;; entry: only those chains whose tail (most specific) class is a
 395   ;; superclass of the class which defined the message need an entry.  We
 396   ;; build a list of these tail classes.
 397   ;;
 398   ;; Having done this, we decide whether it's better to generate a standalone
 399   ;; effective-method function and call it from each of the method entries,
 400   ;; or to inline the effective method body into each of the entries.
 401   ;;
 402   ;; Most of the complexity here comes from (a) dealing with the two
 403   ;; different strategies for constructing method entry functions and (b)
 404   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 405
 406   (let* ((message (effective-method-message method))
 407          (class (effective-method-class method))
 408          (message-class (sod-message-class message))
 409          (return-type (c-type-subtype (sod-message-type message)))
 410          (codegen (make-instance 'method-codegen
 411                                  :message message
 412                                  :class class
 413                                  :method method))
 414
 415          ;; Effective method function details.
 416          (emf-name (effective-method-function-name method))
 417          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 418          (emf-arg-tail (mapcar (lambda (arg)
 419                                  (if (eq (argument-name arg) *sod-ap*)
 420                                      (make-argument *sod-master-ap*
 421                                                     (c-type va-list))
 422                                      arg))
 423                                (sod-message-no-varargs-tail message)))
 424          (emf-type (c-type (fun (lisp return-type)
 425                                 ("sod__obj" (lisp ilayout-type))
 426                                 . (sod-message-no-varargs-tail message))))
 427
 428          ;; Method entry details.
 429          (chain-tails (remove-if-not (lambda (super)
 430                                        (sod-subclass-p super message-class))
 431                                      (mapcar #'car
 432                                              (sod-class-chains class))))
 433          (n-entries (length chain-tails))
 434          (entry-args (sod-message-argument-tail message))
 435          (parm-n (do ((prev "me" (car args))
 436                       (args entry-args (cdr args)))
 437                      ((endp args) nil)
 438                    (when (eq (car args) :ellipsis)
 439                      (return prev))))
 440          (entry-target (codegen-target codegen)))
 441
 442     (flet ((setup-entry (tail)
 443              (let ((head (sod-class-chain-head tail)))
 444                (codegen-push codegen)
 445                (ensure-var codegen "sod__obj" ilayout-type
 446                            (make-convert-to-ilayout-inst class
 447                                                          head "me"))))
 448            (varargs-prologue ()
 449              (ensure-var codegen *sod-master-ap* (c-type va-list))
 450              (emit-inst codegen
 451                         (make-va-start-inst *sod-master-ap* parm-n)))
 452            (varargs-epilogue ()
 453              (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
 454            (finish-entry (tail)
 455              (let* ((head (sod-class-chain-head tail))
 456                     (name (method-entry-function-name method head))
 457                     (type (c-type (fun (lisp return-type)
 458                                        ("me" (* (class tail)))
 459                                        . entry-args))))
 460                (codegen-pop-function codegen name type))))
 461
 462       ;; Generate the method body.  We'll work out what to do with it later.
 463       (codegen-push codegen)
 464       (let* ((result (if (eq return-type c-type-void) nil
 465                          (temporary-var codegen return-type)))
 466              (emf-target (or result :void)))
 467         (compute-effective-method-body method codegen emf-target)
 468         (multiple-value-bind (vars insts) (codegen-pop codegen)
 469           (cond ((or (= n-entries 1)
 470                      (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 471                          *method-entry-inline-threshold*))
 472
 473                  ;; The effective method body is simple -- or there's only
 474                  ;; one of them.  We'll inline the method body into the entry
 475                  ;; functions.
 476                  (dolist (tail chain-tails)
 477                    (setup-entry tail)
 478                    (dolist (var vars)
 479                      (if (typep var 'var-inst)
 480                          (ensure-var codegen (inst-name var)
 481                                      (inst-type var) (inst-init var))
 482                          (emit-decl codegen var)))
 483                    (when parm-n (varargs-prologue))
 484                    (emit-insts codegen insts)
 485                    (when parm-n (varargs-epilogue))
 486                    (deliver-expr codegen entry-target result)
 487                    (finish-entry tail)))
 488
 489                 (t
 490
 491                  ;; The effective method body is complicated and we'd need
 492                  ;; more than one copy.  We'll generate an effective method
 493                  ;; function and call it a lot.
 494                  (codegen-build-function codegen emf-name emf-type vars
 495                   (nconc insts (and result
 496                                     (list (make-return-inst result)))))
 497
 498                  (let ((call (make-call-inst emf-name
 499                               (cons "sod__obj" (mapcar #'argument-name
 500                                                        emf-arg-tail)))))
 501                    (dolist (tail chain-tails)
 502                      (setup-entry tail)
 503                      (cond (parm-n
 504                             (varargs-prologue)
 505                             (convert-stmts codegen entry-target return-type
 506                                            (lambda (target)
 507                                              (deliver-expr codegen
 508                                                            target call)
 509                                              (varargs-epilogue))))
 510                            (t
 511                             (deliver-expr codegen entry-target call)))
 512                      (finish-entry tail)))))))
 513
 514       (codegen-functions codegen))))
 515
 516 (defmethod compute-method-entry-functions
 517     ((method simple-effective-method))
 518   (if (effective-method-primary-methods method)
 519       (call-next-method)
 520       nil))
 521
 522 (defmethod compute-effective-method-body
 523     ((method simple-effective-method) codegen target)
 524   (basic-effective-method-body codegen target method
 525                                (lambda (target)
 526                                  (simple-method-body method
 527                                                      codegen
 528                                                      target))))
 529
 530 ;;;--------------------------------------------------------------------------
 531 ;;; Standard method combination.
 532
 533 (export 'standard-message)
 534 (defclass standard-message (simple-message)
 535   ()
 536   (:documentation
 537    "Message class for standard method combinations.
 538
 539    Standard method combination is a simple method combination where the
 540    primary methods are invoked as a delegation chain, from most- to
 541    least-specific."))
 542
 543 (export 'standard-effective-method)
 544 (defclass standard-effective-method (simple-effective-method) ()
 545   (:documentation "Effective method counterpart to `standard-message'."))
 546
 547 (defmethod primary-method-class ((message standard-message))
 548   'delegating-direct-method)
 549
 550 (defmethod message-effective-method-class ((message standard-message))
 551   'standard-effective-method)
 552
 553 (defmethod simple-method-body
 554     ((method standard-effective-method) codegen target)
 555   (invoke-delegation-chain codegen
 556                            target
 557                            (effective-method-basic-argument-names method)
 558                            (effective-method-primary-methods method)
 559                            nil))
 560
 561 ;;;--------------------------------------------------------------------------
 562 ;;; Aggregate method combinations.
 563
 564 (export 'aggregating-message)
 565 (defclass aggregating-message (simple-message)
 566   ((combination :initarg :combination :type keyword
 567                 :reader message-combination)
 568    (kernel-function :type function :reader message-kernel-function))
 569   (:documentation
 570    "Message class for aggregating method combinations.
 571
 572    An aggregating method combination invokes the primary methods in order,
 573    most-specific first, collecting their return values, and combining them
 574    together in some way to produce a result for the effective method as a
 575    whole.
 576
 577    Mostly, this is done by initializing an accumulator to some appropriate
 578    value, updating it with the result of each primary method in turn, and
 579    finally returning some appropriate output function of it.  The order is
 580    determined by the `:most-specific' property, which may have the value
 581    `:first' or `:last'.
 582
 583    The `progn' method combination is implemented as a slightly weird special
 584    case of an aggregating method combination with a trivial state.  More
 585    typical combinations are `:sum', `:product', `:min', `:max', `:and', and
 586    `:or'.  Finally, there's a `custom' combination which uses user-supplied
 587    code fragments to stitch everything together."))
 588
 589 (export 'aggregating-message-properties)
 590 (defgeneric aggregating-message-properties (message combination)
 591   (:documentation
 592    "Return a description of the properties needed by the method COMBINATION.
 593
 594    The description should be a plist of alternating property name and type
 595    keywords.  The named properties will be looked up in the pset supplied at
 596    initialization time, and supplied to `compute-aggregating-message-kernel'
 597    as keyword arguments.  Defaults can be supplied in method BVLs.
 598
 599    The default is not to capture any property values.
 600
 601    The reason for this is as not to retain the pset beyond message object
 602    initialization.")
 603   (:method (message combination) nil))
 604
 605 (export 'compute-aggregating-message-kernel)
 606 (defgeneric compute-aggregating-message-kernel
 607     (message combination codegen target methods arg-names &key)
 608   (:documentation
 609    "Determine how to aggregate the direct methods for an aggregating message.
 610
 611    The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
 612    METHODS): it should emit, to CODEGEN, an appropriate effective-method
 613    kernel which invokes the listed direct METHODS, in the appropriate order,
 614    collects and aggregates their values, and delivers to TARGET the final
 615    result of the method kernel.
 616
 617    The easy way to implement this method is to use the macro
 618    `define-aggregating-method-combination'."))
 619
 620 (defmethod shared-initialize :before
 621     ((message aggregating-message) slot-names &key pset)
 622   (declare (ignore slot-names))
 623   (with-slots (combination kernel-function) message
 624     (let ((most-specific (get-property pset :most-specific :keyword :first))
 625           (comb (get-property pset :combination :keyword)))
 626
 627       ;; Check that we've been given a method combination and make sure it
 628       ;; actually exists.
 629       (unless comb
 630         (error "The `combination' property is required."))
 631       (unless (some (lambda (method)
 632                       (let* ((specs (method-specializers method))
 633                              (message-spec (car specs))
 634                              (combination-spec (cadr specs)))
 635                         (and (typep message-spec 'class)
 636                              (typep message message-spec)
 637                              (typep combination-spec 'eql-specializer)
 638                              (eq (eql-specializer-object combination-spec)
 639                                  comb))))
 640                     (generic-function-methods
 641                      #'compute-aggregating-message-kernel))
 642         (error "Unknown method combination `~(~A~)'." comb))
 643       (setf combination comb)
 644
 645       ;; Make sure the ordering is actually valid.
 646       (unless (member most-specific '(:first :last))
 647         (error "The `most_specific' property must be `first' or `last'."))
 648
 649       ;; Set up the function which will compute the kernel.
 650       (let ((magic (cons nil nil))
 651             (keys nil))
 652
 653         ;; Collect the property values wanted by the method combination.
 654         (do ((want (aggregating-message-properties message comb)
 655                    (cddr want)))
 656             ((endp want))
 657           (let* ((name (car want))
 658                  (type (cadr want))
 659                  (prop (get-property pset name type magic)))
 660             (unless (eq prop magic)
 661               (setf keys (list* name prop keys)))))
 662
 663         ;; Set the kernel function for later.
 664         (setf kernel-function
 665               (lambda (codegen target arg-names methods)
 666                 (apply #'compute-aggregating-message-kernel
 667                        message comb
 668                        codegen target
 669                        (ecase most-specific
 670                          (:first methods)
 671                          (:last (setf methods (reverse methods))))
 672                        arg-names
 673                        keys)))))))
 674
 675 (export 'check-aggregating-message-type)
 676 (defgeneric check-aggregating-message-type (message combination type)
 677   (:documentation
 678    "Check that TYPE is an acceptable function TYPE for the COMBINATION.
 679
 680    For example, `progn' messages must return `void', while `and' and `or'
 681    messages must return `int'.")
 682   (:method (message combination type)
 683     t))
 684
 685 (defmethod check-message-type ((message aggregating-message) type)
 686   (with-slots (combination) message
 687     (check-aggregating-message-type message combination type)))
 688
 689 (flet ((check (comb want type)
 690          (unless (eq (c-type-subtype type) want)
 691            (error "Messages with `~A' combination must return `~A'."
 692                   (string-downcase comb) want))))
 693   (defmethod check-aggregating-message-type
 694       ((message aggregating-message)
 695        (combination (eql :progn))
 696        (type c-function-type))
 697     (check combination c-type-void type)
 698     (call-next-method))
 699   (defmethod check-aggregating-message-type
 700       ((message aggregating-message)
 701        (combination (eql :and))
 702        (type c-function-type))
 703     (check combination c-type-int type)
 704     (call-next-method))
 705   (defmethod check-aggregating-message-type
 706       ((message aggregating-message)
 707        (combination (eql :or))
 708        (type c-function-type))
 709     (check combination c-type-int type)
 710     (call-next-method)))
 711
 712 (export 'define-aggregating-method-combination)
 713 (defmacro define-aggregating-method-combination
 714     (comb
 715      (vars
 716       &key (codegen (gensym "CODEGEN-"))
 717            (methods (gensym "METHODS-")))
 718      &key properties
 719           ((:around around-func) '#'funcall)
 720           ((:first-method first-method-func) nil firstp)
 721           ((:methods methods-func) '#'funcall))
 722   "Utility macro for definining aggregating method combinations.
 723
 724    The VARS are a list of variable names to be bound to temporary variable
 725    objects of the method's return type.  Additional keyword arguments define
 726    variables names to be bound to other possibly interesting values:
 727
 728      * CODEGEN is the `codegen' object passed at effective-method computation
 729        time; and
 730
 731      * METHODS is the list of primary methods, in the order in which they
 732        should be invoked.  Note that this list must be non-empty, since
 733        otherwise the method on `compute-effective-method-body' specialized to
 734        `simple-effective-method' will suppress the method entirely.
 735
 736    The PROPERTIES, if specified, are a list of properties to be collected
 737    during message-object initialization; items in the list have the form
 738
 739            (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
 740
 741    similar to a `&key' BVL entry, except for the additional TYPE entry.  In
 742    particular, a symbolic NAME may be written in place of a singleton list.
 743    The KEYWORD names the property as it should be looked up in the pset,
 744    while the NAME names a variable to which the property value or default is
 745    bound.
 746
 747    All of these variables, and the VARS, are available in the functions
 748    described below.
 749
 750    The AROUND, FIRST-METHOD, and METHODS are function designators (probably
 751    `lambda' forms) providing pieces of the aggregating behaviour.
 752
 753    The AROUND function is called first, with a single argument BODY, though
 754    the variables above are also in scope.  It is expected to emit code to
 755    CODEGEN which invokes the METHODS in the appropriate order, and arranges
 756    to store the aggregated return value in the first of the VARS.
 757
 758    It may call BODY as a function in order to assist with this; let ARGS be
 759    the list of arguments supplied to it.  The default behaviour is to call
 760    BODY with no arguments.  The BODY function first calls FIRST-METHOD,
 761    passing it as arguments a function INVOKE and the ARGS which were passed
 762    to BODY, and then calls METHODS once for each remaining method, again
 763    passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
 764    specified, then the METHODS function is used for all of the methods.  If
 765    METHODS is not specified, then the behaviour is simply to call INVOKE
 766    immediately.  (See the definition of the `:progn' method combination.)
 767
 768    Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
 769    the appropriate direct method and deliver its return value to TARGET,
 770    which defaults to `:void'."
 771
 772   (with-gensyms (type msg combvar target arg-names args
 773                  meth targ func call-methfunc
 774                  aroundfunc fmethfunc methfunc)
 775     `(progn
 776
 777        ;; If properties are listed, arrange for them to be collected.
 778        ,@(and properties
 779               `((defmethod aggregating-message-properties
 780                     ((,msg aggregating-message) (,combvar (eql ',comb)))
 781                   ',(mapcan (lambda (prop)
 782                               (list (let* ((name (car prop))
 783                                            (names (if (listp name) name
 784                                                       (list name))))
 785                                       (if (cddr names) (car names)
 786                                           (intern (car names) :keyword)))
 787                                     (cadr prop)))
 788                             properties))))
 789
 790        ;; Define the main kernel-compuation method.
 791        (defmethod compute-aggregating-message-kernel
 792            ((,msg aggregating-message) (,combvar (eql ',comb))
 793             ,codegen ,target ,methods ,arg-names
 794             &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
 795                            properties))
 796          (declare (ignore ,combvar))
 797
 798          ;; Declare the necessary variables and give names to the functions
 799          ;; supplied by the caller.
 800          (let* (,@(and vars
 801                        `((,type (c-type-subtype (sod-message-type ,msg)))))
 802                 ,@(mapcar (lambda (var)
 803                             (list var `(temporary-var ,codegen ,type)))
 804                           vars)
 805                 (,aroundfunc ,around-func)
 806                 (,methfunc ,methods-func)
 807                 (,fmethfunc ,(if firstp first-method-func methfunc)))
 808
 809            ;; Arrange to release the temporaries when we're finished with
 810            ;; them.
 811            (unwind-protect
 812                 (progn
 813
 814                   ;; Wrap the AROUND function around most of the work.
 815                   (funcall ,aroundfunc
 816                            (lambda (&rest ,args)
 817                              (flet ((,call-methfunc (,func ,meth)
 818                                       ;; Call FUNC, passing it an INVOKE
 819                                       ;; function which will generate a call
 820                                       ;; to METH.
 821                                       (apply ,func
 822                                              (lambda
 823                                                  (&optional (,targ :void))
 824                                                (invoke-method ,codegen
 825                                                               ,targ
 826                                                               ,arg-names
 827                                                               ,meth))
 828                                              ,args)))
 829
 830                                ;; The first method might need special
 831                                ;; handling.
 832                                (,call-methfunc ,fmethfunc (car ,methods))
 833
 834                                ;; Call the remaining methods in the right
 835                                ;; order.
 836                                (dolist (,meth (cdr ,methods))
 837                                  (,call-methfunc ,methfunc ,meth)))))
 838
 839                   ;; Outside the AROUND function now, deliver the final
 840                   ;; result to the right place.
 841                   (deliver-expr ,codegen ,target ,(car vars)))
 842
 843              ;; Finally, release the temporary variables.
 844              ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
 845                        vars))))
 846
 847        ',comb)))
 848
 849 (define-aggregating-method-combination :progn (nil))
 850
 851 (define-aggregating-method-combination :sum ((acc val) :codegen codegen)
 852   :first-method (lambda (invoke)
 853                   (funcall invoke val)
 854                   (emit-inst codegen (make-set-inst acc val)))
 855   :methods (lambda (invoke)
 856              (funcall invoke val)
 857              (emit-inst codegen (make-update-inst acc #\+ val))))
 858
 859 (define-aggregating-method-combination :product ((acc val) :codegen codegen)
 860   :first-method (lambda (invoke)
 861                   (funcall invoke val)
 862                   (emit-inst codegen (make-set-inst acc val)))
 863   :methods (lambda (invoke)
 864              (funcall invoke val)
 865              (emit-inst codegen (make-update-inst acc #\* val))))
 866
 867 (define-aggregating-method-combination :min ((acc val) :codegen codegen)
 868   :first-method (lambda (invoke)
 869                   (funcall invoke val)
 870                   (emit-inst codegen (make-set-inst acc val)))
 871   :methods (lambda (invoke)
 872              (funcall invoke val)
 873              (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
 874                                               (make-set-inst acc val) nil))))
 875
 876 (define-aggregating-method-combination :max ((acc val) :codegen codegen)
 877   :first-method (lambda (invoke)
 878                   (funcall invoke val)
 879                   (emit-inst codegen (make-set-inst acc val)))
 880   :methods (lambda (invoke)
 881              (funcall invoke val)
 882              (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
 883                                               (make-set-inst acc val) nil))))
 884
 885 (define-aggregating-method-combination :and ((ret val) :codegen codegen)
 886   :around (lambda (body)
 887             (codegen-push codegen)
 888             (deliver-expr codegen ret 0)
 889             (funcall body)
 890             (deliver-expr codegen ret 1)
 891             (emit-inst codegen
 892                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 893   :methods (lambda (invoke)
 894              (funcall invoke val)
 895              (emit-inst codegen (make-if-inst (format nil "!~A" val)
 896                                               (make-break-inst) nil))))
 897
 898 (define-aggregating-method-combination :or ((ret val) :codegen codegen)
 899   :around (lambda (body)
 900             (codegen-push codegen)
 901             (deliver-expr codegen ret 1)
 902             (funcall body)
 903             (deliver-expr codegen ret 0)
 904             (emit-inst codegen
 905                        (make-do-while-inst (codegen-pop-block codegen) 0)))
 906   :methods (lambda (invoke)
 907              (funcall invoke val)
 908              (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
 909
 910 (defmethod aggregating-message-properties
 911     ((message aggregating-message) (combination (eql :custom)))
 912   '(:retvar :id
 913     :valvar :id
 914     :decls :fragment
 915     :before :fragment
 916     :first :fragment
 917     :each :fragment
 918     :after :fragment))
 919
 920 (defmethod compute-aggregating-message-kernel
 921     ((message aggregating-message) (combination (eql :custom))
 922      codegen target methods arg-names
 923      &key (retvar "sod_ret") (valvar "sod_val")
 924           decls before each (first each) after)
 925   (let* ((type (c-type-subtype (sod-message-type message)))
 926          (not-void-p (not (eq type c-type-void))))
 927     (when not-void-p
 928       (ensure-var codegen retvar type)
 929       (ensure-var codegen valvar type))
 930     (when decls
 931       (emit-decl codegen decls))
 932     (labels ((maybe-emit (fragment)
 933                (when fragment (emit-inst codegen fragment)))
 934              (invoke (method fragment)
 935                (invoke-method codegen (if not-void-p valvar :void)
 936                               arg-names method)
 937                (maybe-emit fragment)))
 938       (maybe-emit before)
 939       (invoke (car methods) first)
 940       (dolist (method (cdr methods)) (invoke method each))
 941       (maybe-emit after)
 942       (deliver-expr codegen target retvar))))
 943
 944 (export 'standard-effective-method)
 945 (defclass aggregating-effective-method (simple-effective-method) ()
 946   (:documentation "Effective method counterpart to `aggregating-message'."))
 947
 948 (defmethod message-effective-method-class ((message aggregating-message))
 949   'aggregating-effective-method)
 950
 951 (defmethod simple-method-body
 952     ((method aggregating-effective-method) codegen target)
 953   (let ((argument-names (effective-method-basic-argument-names method))
 954         (primary-methods (effective-method-primary-methods method)))
 955     (funcall (message-kernel-function (effective-method-message method))
 956              codegen target argument-names primary-methods)))
 957
 958 ;;;----- That's all, folks --------------------------------------------------