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   (let ((seq 0))
  50     (setf (slot-value message 'argument-tail)
  51           (mapcar (lambda (arg)
  52                     (if (or (eq arg :ellipsis) (argument-name arg)) arg
  53                         (make-argument (make-instance 'temporary-argument
  54                                                       :tag (prog1 seq
  55                                                              (incf seq)))
  56                                        (argument-type arg))))
  57                   (c-function-arguments (sod-message-type message))))))
  58
  59 (defmethod slot-unbound (class
  60                          (message basic-message)
  61                          (slot-name (eql 'no-varargs-tail)))
  62   (setf (slot-value message 'no-varargs-tail)
  63         (mapcar (lambda (arg)
  64                   (if (eq arg :ellipsis)
  65                       (make-argument *sod-ap* (c-type va-list))
  66                       arg))
  67                 (sod-message-argument-tail message))))
  68
  69 (defmethod sod-message-method-class
  70     ((message basic-message) (class sod-class) pset)
  71   (let ((role (get-property pset :role :keyword nil)))
  72     (case role
  73       ((:before :after) 'daemon-direct-method)
  74       (:around 'delegating-direct-method)
  75       ((nil) (error "How odd: a primary method slipped through the net"))
  76       (t (error "Unknown method role ~A" role)))))
  77
  78 (export 'simple-message)
  79 (defclass simple-message (basic-message)
  80   ()
  81   (:documentation
  82    "Base class for messages with `simple' method combinations.
  83
  84    A simple method combination is one which has only one method role other
  85    than the `before', `after' and `around' methods provided by
  86    `basic-message'.  We call these `primary' methods, and the programmer
  87    designates them by not specifying an explicit role.
  88
  89    If the programmer doesn't define any primary methods then the effective
  90    method is null -- i.e., the method entry pointer shows up as a null
  91    pointer."))
  92
  93 (defmethod sod-message-method-class
  94     ((message simple-message) (class sod-class) pset)
  95   (if (get-property pset :role :keyword nil)
  96       (call-next-method)
  97       (primary-method-class message)))
  98
  99 ;;;--------------------------------------------------------------------------
 100 ;;; Direct method classes.
 101
 102 (export 'basic-direct-method)
 103 (defclass basic-direct-method (sod-method)
 104   ((role :initarg :role :type symbol :reader sod-method-role)
 105    (function-type :type c-function-type :reader sod-method-function-type))
 106   (:documentation
 107    "Base class for built-in direct method classes.
 108
 109    Provides the basic functionality for the built-in direct-method classes.
 110    This is a separate class so that `special effect' methods can avoid
 111    inheriting its default behaviour and slots.
 112
 113    A basic method can be assigned a `role', which may be set either as an
 114    initarg or using the `:role' property.  Roles are used for method
 115    categorization.
 116
 117    The function type protocol is implemented on `basic-direct-method' using
 118    slot reader methods.  The actual values are computed on demand in methods
 119    defined on `slot-unbound'."))
 120
 121 (defmethod shared-initialize :after
 122     ((method basic-direct-method) slot-names &key pset)
 123   (declare (ignore slot-names))
 124   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 125
 126 (defmethod slot-unbound
 127     (class (method basic-direct-method) (slot-name (eql 'function-type)))
 128   (let ((type (sod-method-type method)))
 129     (setf (slot-value method 'function-type)
 130           (c-type (fun (lisp (c-type-subtype type))
 131                        ("me" (* (class (sod-method-class method))))
 132                        . (c-function-arguments type))))))
 133
 134 (defmethod sod-method-function-name ((method basic-direct-method))
 135   (with-slots (class role message) method
 136     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 137             (sod-class-nickname (sod-message-class message))
 138             (sod-message-name message))))
 139
 140 (export 'daemon-direct-method)
 141 (defclass daemon-direct-method (basic-direct-method)
 142   ()
 143   (:documentation
 144    "A daemon direct method is invoked for side effects and cannot override.
 145
 146    This is the direct method class for `before' and `after' methods, which
 147    cannot choose to override the remaining methods and are not involved in
 148    the computation of the final result.
 149
 150    In C terms, a daemon method must return `void', and is not passed a
 151    `next_method' pointer."))
 152
 153 (defmethod check-method-type ((method daemon-direct-method)
 154                               (message sod-message)
 155                               (type c-function-type))
 156   (with-slots ((msgtype type)) message
 157     (unless (c-type-equal-p (c-type-subtype type) (c-type void))
 158       (error "Method return type ~A must be `void'" (c-type-subtype type)))
 159     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 160                                          (c-function-arguments type))
 161       (error "Method arguments ~A don't match message ~A" type msgtype))))
 162
 163 (export 'delegating-direct-method)
 164 (defclass delegating-direct-method (basic-direct-method)
 165   ((next-method-type :type c-function-type
 166                      :reader sod-method-next-method-type))
 167   (:documentation
 168    "A delegating direct method can choose to override other methods.
 169
 170    This is the direct method class for `around' and standard-method-
 171    combination primary methods, which are given the choice of computing the
 172    entire method's result or delegating to (usually) less-specific methods.
 173
 174    In C terms, a delegating method is passed a `next_method' pointer so that
 175    it can delegate part of its behaviour.  (A delegating direct method for a
 176    varargs message is also given an additional `va_list' argument,
 177    conventionally named `sod__ap_master', which it is expected to pass on to
 178    its `next_method' function if necessary.)
 179
 180    The function type protocol is implemented on `delegating-direct-method'
 181    using slot reader methods.  The actual values are computed on demand in
 182    methods defined on `slot-unbound'."))
 183
 184 (defmethod slot-unbound (class
 185                          (method delegating-direct-method)
 186                          (slot-name (eql 'next-method-type)))
 187   (let* ((message (sod-method-message method))
 188          (type (sod-message-type message)))
 189     (setf (slot-value method 'next-method-type)
 190           (c-type (fun (lisp (c-type-subtype type))
 191                        ("me" (* (class (sod-method-class method))))
 192                        . (c-function-arguments type))))))
 193
 194 (defmethod slot-unbound (class
 195                          (method delegating-direct-method)
 196                          (slot-name (eql 'function-type)))
 197   (let* ((message (sod-method-message method))
 198          (type (sod-method-type method))
 199          (method-args (c-function-arguments type)))
 200     (setf (slot-value method 'function-type)
 201           (c-type (fun (lisp (c-type-subtype type))
 202                        ("me" (* (class (sod-method-class method))))
 203                        ("next_method" (* (lisp (commentify-function-type
 204                                                 (sod-method-next-method-type
 205                                                  method)))))
 206                        .
 207                        (if (varargs-message-p message)
 208                            (cons (make-argument *sod-master-ap*
 209                                                 (c-type va-list))
 210                                  method-args)
 211                            method-args))))))
 212
 213 ;;;--------------------------------------------------------------------------
 214 ;;; Effective method classes.
 215
 216 (export 'basic-effective-method)
 217 (defclass basic-effective-method (effective-method)
 218   ((around-methods :initarg :around-methods :initform nil
 219                    :type list :reader effective-method-around-methods)
 220    (before-methods :initarg :before-methods :initform nil
 221                    :type list :reader effective-method-before-methods)
 222    (after-methods :initarg :after-methods :initform nil
 223                   :type list :reader effective-method-after-methods)
 224    (basic-argument-names :type list
 225                          :reader effective-method-basic-argument-names)
 226    (functions :type list :reader effective-method-functions))
 227   (:documentation
 228    "Base class for built-in effective method classes.
 229
 230    This class maintains lists of the applicable `before', `after' and
 231    `around' methods and provides behaviour for invoking these methods
 232    correctly.
 233
 234    The argument names protocol is implemented on `basic-effective-method'
 235    using a slot reader method.  The actual values are computed on demand in
 236    methods defined on `slot-unbound'."))
 237
 238 (defmethod slot-unbound (class
 239                          (method basic-effective-method)
 240                          (slot-name (eql 'basic-argument-names)))
 241   (let ((message (effective-method-message method)))
 242     (setf (slot-value method 'basic-argument-names)
 243           (subst *sod-master-ap* *sod-ap*
 244                  (mapcar #'argument-name
 245                          (sod-message-no-varargs-tail message))))))
 246
 247 (defmethod effective-method-function-name ((method effective-method))
 248   (let* ((class (effective-method-class method))
 249          (message (effective-method-message method))
 250          (message-class (sod-message-class message)))
 251     (format nil "~A__emethod_~A__~A"
 252             class
 253             (sod-class-nickname message-class)
 254             (sod-message-name message))))
 255
 256 (defmethod slot-unbound
 257     (class (method basic-effective-method) (slot-name (eql 'functions)))
 258   (setf (slot-value method 'functions)
 259         (compute-method-entry-functions method)))
 260
 261 (export 'simple-effective-method)
 262 (defclass simple-effective-method (basic-effective-method)
 263   ((primary-methods :initarg :primary-methods :initform nil
 264                     :type list :reader effective-method-primary-methods))
 265   (:documentation
 266    "Effective method counterpart to `simple-message'."))
 267
 268 (defmethod shared-initialize :after
 269     ((method simple-effective-method) slot-names &key direct-methods)
 270   (declare (ignore slot-names))
 271   (categorize (method direct-methods :bind ((role (sod-method-role method))))
 272       ((primary (null role))
 273        (before (eq role :before))
 274        (after (eq role :after))
 275        (around (eq role :around)))
 276     (with-slots (primary-methods before-methods after-methods around-methods)
 277         method
 278       (setf primary-methods primary
 279             before-methods before
 280             after-methods (reverse after)
 281             around-methods around))))
 282
 283 ;;;--------------------------------------------------------------------------
 284 ;;; Code generation.
 285
 286 (defmethod shared-initialize :after
 287     ((codegen method-codegen) slot-names &key)
 288   (with-slots (message target) codegen
 289     (setf target
 290           (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
 291               :void
 292               :return))))
 293
 294 ;;;--------------------------------------------------------------------------
 295 ;;; Invoking direct methods.
 296
 297 (export 'basic-effective-method-body)
 298 (defun basic-effective-method-body (codegen target method body)
 299   "Build the common method-invocation structure.
 300
 301    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 302    the `around' methods, from most- to least-specific.  If they all delegate,
 303    then the `before' methods are run, most-specific first; next, the
 304    instructions generated by BODY (invoked with a target argument); then, the
 305    `after' methods are run, least-specific first; and, finally, the value
 306    delivered by the BODY is returned to the `around' methods.  The result
 307    returned by the outermost `around' method -- or, if there are none,
 308    delivered by the BODY -- is finally delivered to the TARGET."
 309
 310   (with-slots (message class before-methods after-methods around-methods)
 311       method
 312     (let* ((message-type (sod-message-type message))
 313            (return-type (c-type-subtype message-type))
 314            (voidp (eq return-type (c-type void)))
 315            (basic-tail (effective-method-basic-argument-names method)))
 316       (flet ((method-kernel (target)
 317                (dolist (before before-methods)
 318                  (invoke-method codegen :void basic-tail before))
 319                (if (or voidp (null after-methods))
 320                    (funcall body target)
 321                    (convert-stmts codegen target return-type
 322                                   (lambda (target)
 323                                     (funcall body target)
 324                                     (dolist (after (reverse after-methods))
 325                                       (invoke-method codegen :void
 326                                                      after basic-tail)))))))
 327         (invoke-delegation-chain codegen target basic-tail
 328                                  around-methods #'method-kernel)))))
 329
 330 ;;;--------------------------------------------------------------------------
 331 ;;; Method entry points.
 332
 333 (defparameter *method-entry-inline-threshold* 200
 334   "Threshold below which effective method bodies are inlined into entries.
 335
 336    After the effective method body has been computed, we calculate its
 337    metric, multiply by the number of entries we need to generate, and compare
 338    it with this threshold.  If the metric is below the threshold then we
 339    fold the method body into the entry functions; otherwise we split the
 340    effective method out into its own function.")
 341
 342 (defmethod method-entry-function-name
 343     ((method effective-method) (chain-head sod-class))
 344   (let* ((class (effective-method-class method))
 345          (message (effective-method-message method))
 346          (message-class (sod-message-class message)))
 347     (if (or (not (slot-boundp method 'functions))
 348             (slot-value method 'functions))
 349         (format nil "~A__mentry_~A__~A__chain_~A"
 350                 class
 351                 (sod-class-nickname message-class)
 352                 (sod-message-name message)
 353                 (sod-class-nickname chain-head))
 354         0)))
 355
 356 (defmethod method-entry-function-type ((entry method-entry))
 357   (let* ((method (method-entry-effective-method entry))
 358          (message (effective-method-message method))
 359          (type (sod-message-type message)))
 360     (c-type (fun (lisp (c-type-subtype type))
 361                  ("me" (* (class (method-entry-chain-tail entry))))
 362                  . (sod-message-argument-tail message)))))
 363
 364 (defmethod make-method-entry ((method basic-effective-method)
 365                               (chain-head sod-class) (chain-tail sod-class))
 366   (make-instance 'method-entry
 367                  :method method
 368                  :chain-head chain-head
 369                  :chain-tail chain-tail))
 370
 371 (defmethod compute-method-entry-functions ((method basic-effective-method))
 372
 373   ;; OK, there's quite a lot of this, so hold tight.
 374   ;;
 375   ;; The first thing we need to do is find all of the related objects.  This
 376   ;; is a bit verbose but fairly straightforward.
 377   ;;
 378   ;; Next, we generate the effective method body -- using `compute-effective-
 379   ;; method-body' of all things.  This gives us the declarations and body for
 380   ;; an effective method function, but we don't have an actual function yet.
 381   ;;
 382   ;; Now we look at the chains which are actually going to need a method
 383   ;; entry: only those chains whose tail (most specific) class is a
 384   ;; superclass of the class which defined the message need an entry.  We
 385   ;; build a list of these tail classes.
 386   ;;
 387   ;; Having done this, we decide whether it's better to generate a standalone
 388   ;; effective-method function and call it from each of the method entries,
 389   ;; or to inline the effective method body into each of the entries.
 390   ;;
 391   ;; Most of the complexity here comes from (a) dealing with the two
 392   ;; different strategies for constructing method entry functions and (b)
 393   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 394
 395   (let* ((message (effective-method-message method))
 396          (class (effective-method-class method))
 397          (message-class (sod-message-class message))
 398          (return-type (c-type-subtype (sod-message-type message)))
 399          (codegen (make-instance 'method-codegen
 400                                  :message message
 401                                  :class class
 402                                  :method method))
 403
 404          ;; Effective method function details.
 405          (emf-name (effective-method-function-name method))
 406          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 407          (emf-arg-tail (mapcar (lambda (arg)
 408                                  (if (eq (argument-name arg) *sod-ap*)
 409                                      (make-argument *sod-master-ap*
 410                                                     (c-type va-list))
 411                                      arg))
 412                                (sod-message-no-varargs-tail message)))
 413          (emf-type (c-type (fun (lisp return-type)
 414                                 ("sod__obj" (lisp ilayout-type))
 415                                 . (sod-message-no-varargs-tail message))))
 416          (result (if (eq return-type (c-type void)) nil
 417                      (temporary-var codegen return-type)))
 418          (emf-target (or result :void))
 419
 420          ;; Method entry details.
 421          (chain-tails (remove-if-not (lambda (super)
 422                                        (sod-subclass-p super message-class))
 423                                      (mapcar #'car
 424                                              (sod-class-chains class))))
 425          (n-entries (length chain-tails))
 426          (entry-args (sod-message-argument-tail message))
 427          (parm-n (do ((prev "me" (car args))
 428                       (args entry-args (cdr args)))
 429                      ((endp args) nil)
 430                    (when (eq (car args) :ellipsis)
 431                      (return prev))))
 432          (entry-target (codegen-target codegen)))
 433
 434     (flet ((setup-entry (tail)
 435              (let ((head (sod-class-chain-head tail)))
 436                (codegen-push codegen)
 437                (ensure-var codegen "sod__obj" ilayout-type
 438                            (make-convert-to-ilayout-inst class
 439                                                          head "me"))))
 440            (varargs-prologue ()
 441              (ensure-var codegen *sod-master-ap* (c-type va-list))
 442              (emit-inst codegen
 443                         (make-va-start-inst *sod-master-ap* parm-n)))
 444            (varargs-epilogue ()
 445              (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
 446            (finish-entry (tail)
 447              (let* ((head (sod-class-chain-head tail))
 448                     (name (method-entry-function-name method head))
 449                     (type (c-type (fun (lisp return-type)
 450                                        ("me" (* (class tail)))
 451                                        . entry-args))))
 452                (codegen-pop-function codegen name type))))
 453
 454       ;; Generate the method body.  We'll work out what to do with it later.
 455       (codegen-push codegen)
 456       (compute-effective-method-body method codegen emf-target)
 457       (multiple-value-bind (vars insts) (codegen-pop codegen)
 458         (cond ((or (= n-entries 1)
 459                    (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 460                        *method-entry-inline-threshold*))
 461
 462                ;; The effective method body is simple -- or there's only one
 463                ;; of them.  We'll inline the method body into the entry
 464                ;; functions.
 465                (dolist (tail chain-tails)
 466                  (setup-entry tail)
 467                  (dolist (var vars)
 468                    (ensure-var codegen (inst-name var)
 469                                (inst-type var) (inst-init var)))
 470                  (when parm-n (varargs-prologue))
 471                  (emit-insts codegen insts)
 472                  (when parm-n (varargs-epilogue))
 473                  (deliver-expr codegen entry-target result)
 474                  (finish-entry tail)))
 475
 476               (t
 477
 478                ;; The effective method body is complicated and we'd need more
 479                ;; than one copy.  We'll generate an effective method function
 480                ;; and call it a lot.
 481                (codegen-build-function codegen emf-name emf-type vars
 482                 (nconc insts (and result (list (make-return-inst result)))))
 483
 484                (let ((call (make-call-inst emf-name
 485                             (cons "sod__obj" (mapcar #'argument-name
 486                                                      emf-arg-tail)))))
 487                  (dolist (tail chain-tails)
 488                    (setup-entry tail)
 489                    (cond (parm-n
 490                           (varargs-prologue)
 491                           (convert-stmts codegen entry-target return-type
 492                                          (lambda (target)
 493                                            (deliver-expr codegen target call)
 494                                            (varargs-epilogue))))
 495                          (t
 496                           (deliver-expr codegen entry-target call)))
 497                    (finish-entry tail))))))
 498
 499       (codegen-functions codegen))))
 500
 501 (defmethod compute-method-entry-functions
 502     ((method simple-effective-method))
 503   (if (effective-method-primary-methods method)
 504       (call-next-method)
 505       nil))
 506
 507 (defmethod compute-effective-method-body
 508     ((method simple-effective-method) codegen target)
 509   (with-slots (message basic-argument-names primary-methods) method
 510     (basic-effective-method-body codegen target method
 511                                  (lambda (target)
 512                                    (simple-method-body method
 513                                                        codegen
 514                                                        target)))))
 515
 516 ;;;--------------------------------------------------------------------------
 517 ;;; Standard method combination.
 518
 519 (export 'standard-message)
 520 (defclass standard-message (simple-message)
 521   ()
 522   (:documentation
 523    "Message class for standard method combination.
 524
 525    Standard method combination is a simple method combination where the
 526    primary methods are invoked as a delegation chain, from most- to
 527    least-specific."))
 528
 529 (export 'standard-effective-method)
 530 (defclass standard-effective-method (simple-effective-method) ()
 531   (:documentation "Effective method counterpart to `standard-message'."))
 532
 533 (defmethod primary-method-class ((message standard-message))
 534   'delegating-direct-method)
 535
 536 (defmethod message-effective-method-class ((message standard-message))
 537   'standard-effective-method)
 538
 539 (defmethod simple-method-body
 540     ((method standard-effective-method) codegen target)
 541   (invoke-delegation-chain codegen
 542                            target
 543                            (effective-method-basic-argument-names method)
 544                            (effective-method-primary-methods method)
 545                            nil))
 546
 547 ;;;----- That's all, folks --------------------------------------------------