mdw@git.distorted.org.uk Git - sod/blob - src/method-proto.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Method combination protocol
   4 ;;;
   5 ;;; (c) 2009 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 ;;; Effective methods and entries.
  30
  31 (export '(effective-method
  32           effective-method-message effective-method-class
  33           effective-method-keywords))
  34 (defclass effective-method ()
  35   ((message :initarg :message :type sod-message
  36             :reader effective-method-message)
  37    (%class :initarg :class :type sod-class :reader effective-method-class)
  38    (keywords :type list :reader effective-method-keywords))
  39   (:documentation
  40    "The behaviour invoked by sending a message to an instance of a class.
  41
  42    This class describes the behaviour when an instance of CLASS is sent
  43    MESSAGE.
  44
  45    This is not a useful class by itself.  Message classes are expected to
  46    define their own effective-method classes.
  47
  48    An effective method class may accept a `:direct-methods' initarg, which
  49    will be a list of applicable methods sorted in most-to-least specific
  50    order."))
  51
  52 (export 'sod-message-applicable-methods)
  53 (defgeneric sod-message-applicable-methods (message class)
  54   (:documentation
  55    "Return a list of applicable methods for a MESSAGE.
  56
  57    The list contains all methods applicable for MESSAGE when sent to an
  58    instance of CLASS, most specific first."))
  59
  60 (export 'sod-message-keyword-argument-lists)
  61 (defgeneric sod-message-keyword-argument-lists
  62     (message class direct-methods state)
  63   (:documentation
  64    "Returns a list of keyword argument lists to be merged.
  65
  66    This should return a list suitable for passing to `merge-keyword-lists',
  67    i.e., each element should be a pair consisting of a function describing
  68    the source of the argument list (returning location and description), and
  69    a list of `argument' objects.
  70
  71    The MESSAGE is the message being processed; CLASS is a receiver class
  72    under consideration; DIRECT-METHODS is the complete list of applicable
  73    direct methods (most specific first); and STATE is an `inheritance-path-
  74    reporter-state' object which can be used by the returned reporting
  75    functions."))
  76
  77 (export 'compute-effective-method-keyword-arguments)
  78 (defun compute-effective-method-keyword-arguments
  79     (message class direct-methods)
  80   "Return a merged keyword argument list.
  81
  82    The returned list combines all of the applicable methods, provided as
  83    DIRECT-METHODS, applicable to MESSAGE when received by an instance of
  84    CLASS, possibly with other keywords as determined by `sod-keyword-
  85    argument-lists'."
  86   (let ((state (make-inheritance-path-reporter-state class)))
  87     (merge-keyword-lists (lambda ()
  88                            (values class
  89                                    (format nil
  90                                            "methods for message `~A' ~
  91                                             applicable to class `~A'"
  92                                            message class)))
  93                          (sod-message-keyword-argument-lists message
  94                                                              class
  95                                                              direct-methods
  96                                                              state))))
  97
  98 (export 'sod-message-check-methods)
  99 (defgeneric sod-message-check-methods (message class direct-methods)
 100   (:documentation
 101    "Check that the applicable methods for a MESSAGE are compatible.
 102
 103    Specifically, given the DIRECT-METHODS applicable for the message when
 104    received by an instance of CLASS, signal errors if the methods don't
 105    match the MESSAGE or each other."))
 106
 107 (export 'sod-message-effective-method-class)
 108 (defgeneric sod-message-effective-method-class (message)
 109   (:documentation
 110    "Return the effective method class for the given MESSAGE.
 111
 112    This function is invoked by `compute-sod-effective-method'."))
 113
 114 (export 'primary-method-class)
 115 (defgeneric primary-method-class (message)
 116   (:documentation
 117    "Return the name of the primary direct method class for MESSAGE.
 118
 119    This protocol is used by `simple-message' subclasses."))
 120
 121 (export 'compute-sod-effective-method)
 122 (defgeneric compute-sod-effective-method (message class)
 123   (:documentation
 124    "Return the effective method when a CLASS instance receives MESSAGE.
 125
 126    The default method constructs an instance of the message's chosen
 127    `sod-message-effective-method-class', passing the MESSAGE, the CLASS and
 128    the list of applicable methods as initargs to `make-instance'."))
 129
 130 (export 'compute-effective-methods)
 131 (defgeneric compute-effective-methods (class)
 132   (:documentation
 133    "Return a list of all of the effective methods needed for CLASS.
 134
 135    The list needn't be in any particular order."))
 136
 137 (export '(method-entry method-entry-effective-method
 138           method-entry-chain-head method-entry-chain-tail))
 139 (defclass method-entry ()
 140   ((%method :initarg :method :type effective-method
 141             :reader method-entry-effective-method)
 142    (chain-head :initarg :chain-head :type sod-class
 143                :reader method-entry-chain-head)
 144    (chain-tail :initarg :chain-tail :type sod-class
 145                :reader method-entry-chain-tail)
 146    (role :initarg :role :type (or keyword null) :reader method-entry-role))
 147   (:documentation
 148    "An entry point into an effective method.
 149
 150    Specifically, this is the entry point to the effective METHOD invoked via
 151    the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE.
 152    The CHAIN-TAIL is the most specific class on this chain; this is useful
 153    because we can reuse the types of method entries from superclasses on
 154    non-primary chains.
 155
 156    Each effective method may have several different method entries, because
 157    an effective method can be called via vtables attached to different
 158    chains, and such calls will pass instance pointers which point to
 159    different `ichain' structures within the overall instance layout; it's the
 160    job of the method entry to adjust the instance pointers correctly for the
 161    rest of the effective method.
 162
 163    A vtable can contain more than one entry for the same message.  Such
 164    entries are distinguished by their roles.  A message always has an entry
 165    with the `nil role; in addition, a varargs message also has a `:valist'
 166    role, which accepts a `va_list' argument in place of the variable argument
 167    listNo other roles are currently defined, though they may be introduced by
 168    extensions.
 169
 170    The boundaries between a method entry and the effective method
 171    is (intentionally) somewhat fuzzy.  In extreme cases, the effective method
 172    may not exist at all as a distinct entity in the output because its
 173    content is duplicated in all of the method entry functions.  This is left
 174    up to the effective method protocol."))
 175
 176 (export 'make-method-entries)
 177 (defgeneric make-method-entries (effective-method chain-head chain-tail)
 178   (:documentation
 179    "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called
 180    via CHAIN-HEAD.
 181
 182    There is no default method for this function.  (Maybe when the
 183    effective-method/method-entry output protocol has settled down I'll know
 184    what a sensible default action would be.)"))
 185
 186 ;;;--------------------------------------------------------------------------
 187 ;;; Protocol for messages and direct-methods.
 188
 189 (export 'sod-message-argument-tail)
 190 (defgeneric sod-message-argument-tail (message)
 191   (:documentation
 192    "Return the argument tail for the message, with invented argument names.
 193
 194    No `me' argument is prepended; any `:ellipsis' is left as it is."))
 195
 196 (export 'sod-method-description)
 197 (defgeneric sod-method-description (method)
 198   (:documentation
 199    "Return an adjectival phrase describing METHOD.
 200
 201     The result will be placed into an error message reading something like
 202     ``Conflicting definition of DESCRIPTION direct method `bogus'''.  Two
 203     direct methods which can coexist in the same class, defined on the same
 204     message, should have differing descriptions."))
 205
 206 (export 'sod-method-function-type)
 207 (defgeneric sod-method-function-type (method)
 208   (:documentation
 209    "Return the C function type for the direct method.
 210
 211    This is called during initialization of a direct method object, and the
 212    result is cached.
 213
 214    A default method is provided (by `basic-direct-method') which simply
 215    prepends an appropriate `me' argument to the user-provided argument list.
 216    Fancy method classes may need to override this behaviour."))
 217
 218 (export 'sod-method-next-method-type)
 219 (defgeneric sod-method-next-method-type (method)
 220   (:documentation
 221    "Return the C function type for the next-method trampoline.
 222
 223    This is called during initialization of a direct method object, and the
 224    result is cached.  It should return a function type, not a pointer type.
 225
 226    A default method is provided (by `delegating-direct-method') which should
 227    do the right job.  Very fancy subclasses might need to do something
 228    different."))
 229
 230 (export 'sod-method-function-name)
 231 (defgeneric sod-method-function-name (method)
 232   (:documentation
 233    "Return the C function name for the direct method."))
 234
 235 (export 'keyword-message-p)
 236 (defun keyword-message-p (message)
 237   "Answer whether the MESSAGE accepts a keyword arguments.
 238
 239    Dealing with keyword messages is rather fiddly, so this is useful to
 240    know."
 241   (typep (sod-message-type message) 'c-keyword-function-type))
 242
 243 (export 'varargs-message-p)
 244 (defun varargs-message-p (message)
 245   "Answer whether the MESSAGE accepts a variable-length argument list.
 246
 247    We need to jump through some extra hoops in order to cope with varargs
 248    messages, so this is useful to know."
 249   (member :ellipsis (sod-message-argument-tail message)))
 250
 251 ;;;--------------------------------------------------------------------------
 252 ;;; Protocol for effective methods and method entries.
 253
 254 (export 'method-entry-function-type)
 255 (defgeneric method-entry-function-type (entry)
 256   (:documentation
 257    "Return the C function type for a method entry."))
 258
 259 (export 'method-entry-slot-name)
 260 (defgeneric method-entry-slot-name (entry)
 261   (:documentation
 262    "Return the `vtmsgs' slot name for a method entry.
 263
 264    The default method indirects through `method-entry-slot-name-by-role'."))
 265
 266 (defgeneric method-entry-slot-name-by-role (entry role name)
 267   (:documentation "Easier implementation for `method-entry-slot-name'.")
 268   (:method ((entry method-entry) (role (eql nil)) name) name)
 269   (:method ((entry method-entry) (role (eql :valist)) name)
 270     (format nil "~A__v" name)))
 271
 272 (export 'effective-method-basic-argument-names)
 273 (defgeneric effective-method-basic-argument-names (method)
 274   (:documentation
 275    "Return a list of argument names to be passed to direct methods.
 276
 277    The argument names are constructed from the message's arguments returned
 278    by `sod-message-argument-tail', with any ellipsis replaced by an explicit
 279    `va_list' argument.  The basic arguments are the ones immediately derived
 280    from the programmer's explicitly stated arguments; the `me' argument is
 281    not included, and neither are more exotic arguments added as part of the
 282    method delegation protocol."))
 283
 284 (export 'effective-method-live-p)
 285 (defgeneric effective-method-live-p (method)
 286   (:documentation
 287    "Returns true if the effective METHOD is live.
 288
 289    An effective method is `live' if it should actually have proper method entry
 290    functions associated with it and stored in the class vtable.  The other
 291    possibility is that the method is `dead', in which case the function
 292    pointers in the vtable are left null."))
 293
 294 ;;;--------------------------------------------------------------------------
 295 ;;; Code generation.
 296
 297 ;;; Enhanced code-generator class.
 298
 299 (export '(method-codegen codegen-message codegen-class
 300           codegen-method codegen-target))
 301 (defclass method-codegen (codegen)
 302   ((message :initarg :message :type sod-message :reader codegen-message)
 303    (%class :initarg :class :type sod-class :reader codegen-class)
 304    (%method :initarg :method :type effective-method :reader codegen-method)
 305    (target :initarg :target :reader codegen-target))
 306   (:documentation
 307    "Augments CODEGEN with additional state regarding an effective method.
 308
 309    We store the effective method, and also its target class and owning
 310    message, so that these values are readily available to the code-generating
 311    functions."))
 312
 313 ;;; Protocol.
 314
 315 (export 'compute-effective-method-body)
 316 (defgeneric compute-effective-method-body (method codegen target)
 317   (:documentation
 318    "Generates the body of an effective method.
 319
 320    Writes the function body to the code generator.  It can (obviously)
 321    generate auxiliary functions if it needs to.
 322
 323    The arguments are as determined by agreement with the generic function
 324    `compute-method-entry-functions'; usually this will be as specified by the
 325    `sod-message-argument-tail', with any variable-argument tail reified to a
 326    `va_list', and an additional argument `sod__obj' of type pointer-to-
 327    ilayout.  The code should deliver the result (if any) to the TARGET."))
 328
 329 (export 'simple-method-body)
 330 (defgeneric simple-method-body (method codegen target)
 331   (:documentation
 332    "Generate the body of a simple effective method.
 333
 334    The function is invoked on an effective METHOD, with a CODEGEN to which it
 335    should emit code delivering the method's value to TARGET."))
 336
 337 ;;; Additional instructions.
 338
 339 ;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the
 340 ;; slot names, because `expr' is exported by our package, and `class' is
 341 ;; actually from the `common-lisp' package.
 342 (definst convert-to-ilayout (stream :export t)
 343     (#1=#:class chain-head #2=#:expr)
 344   (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
 345           #1# (sod-class-nickname chain-head) #2#))
 346
 347 ;;; Utilities.
 348
 349 (defvar-unbound *keyword-struct-disposition*
 350   "The current state of the keyword structure.
 351
 352    This can be one of three values.
 353
 354      * `:local' -- the structure itself is in a local variable `sod__kw'.
 355        This is used in the top-level effective method.
 356
 357      * `:pointer' -- the structure is pointed to by the local variable
 358        `sod__kw'.  This is used by delegation-chain trampolines.
 359
 360      * `:null' -- there is in fact no structure because none of the
 361        applicable methods actually define any keywords.")
 362
 363 (defun keyword-access (name &optional suffix)
 364   "Return an lvalue designating a named member of the keyword struct.
 365
 366    If a non-nil SUFFIX is provided, then the member is named NAMESUFFIX."
 367   (flet ((mem (op)
 368            (format nil "~A~A~A~@[~A~]" *sod-keywords* op name suffix)))
 369     (ecase *keyword-struct-disposition*
 370       (:local (mem "."))
 371       (:pointer (mem "->")))))
 372
 373 (let ((kw-addr (format nil "&~A" *sod-keywords*)))
 374   (defun keyword-struct-pointer ()
 375     "Return a pointer to the keyword structure."
 376     (ecase *keyword-struct-disposition*
 377       (:local kw-addr)
 378       (:pointer *sod-keywords*)
 379       (:null *null-pointer*))))
 380
 381 (export 'invoke-method)
 382 (defun invoke-method (codegen target arguments-tail direct-method)
 383   "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
 384
 385    The code is generated in the context of CODEGEN, which can be any instance
 386    of the `codegen' class -- it needn't be an instance of `method-codegen'.
 387    The DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of
 388    argument expressions), preceded by a `me' argument of type pointer-to-
 389    CLASS where CLASS is the class on which the method was defined.
 390
 391    If the message accepts a variable-length argument list then a copy of the
 392    prevailing argument pointer is provided in place of the `:ellipsis'."
 393
 394   (let* ((message (sod-method-message direct-method))
 395          (class (sod-method-class direct-method))
 396          (function (sod-method-function-name direct-method))
 397          (type (sod-method-type direct-method))
 398          (keywordsp (keyword-message-p message))
 399          (keywords (and keywordsp (c-function-keywords type)))
 400          (arguments (append (list (format nil "&sod__obj->~A.~A"
 401                                           (sod-class-nickname
 402                                            (sod-class-chain-head class))
 403                                           (sod-class-nickname class)))
 404                             arguments-tail
 405                             (mapcar (lambda (arg)
 406                                       (let ((name (argument-name arg))
 407                                             (default (argument-default arg)))
 408                                         (if default
 409                                             (make-cond-inst
 410                                              (keyword-access name
 411                                                              "__suppliedp")
 412                                              (keyword-access name)
 413                                              default)
 414                                             (keyword-access name))))
 415                                     keywords))))
 416     (cond ((varargs-message-p message)
 417            (convert-stmts codegen target (c-type-subtype type)
 418                           (lambda (var)
 419                             (ensure-var codegen *sod-tmp-ap* c-type-va-list)
 420                             (deliver-call codegen :void "va_copy"
 421                                           *sod-tmp-ap* *sod-ap*)
 422                             (apply #'deliver-call codegen var
 423                                    function arguments)
 424                             (deliver-call codegen :void "va_end"
 425                                           *sod-tmp-ap*))))
 426           (keywords
 427            (let ((tag (direct-method-suppliedp-struct-tag direct-method)))
 428              (with-temporary-var (codegen spvar (c-type (struct tag)))
 429                (dolist (arg keywords)
 430                  (let ((name (argument-name arg)))
 431                    (deliver-expr codegen (format nil "~A.~A" spvar name)
 432                                  (keyword-access name "__suppliedp"))))
 433                (setf arguments (list* (car arguments) spvar
 434                                       (cdr arguments)))
 435                (apply #'deliver-call codegen target function arguments))))
 436           (t
 437            (apply #'deliver-call codegen target function arguments)))))
 438
 439 (export 'ensure-ilayout-var)
 440 (defun ensure-ilayout-var (codegen super)
 441   "Define a variable `sod__obj' pointing to the class's ilayout structure.
 442
 443    CODEGEN is a `method-codegen'.  The class in question is CODEGEN's class,
 444    i.e., the target class for the effective method.  SUPER is one of the
 445    class's superclasses; it is assumed that `me' is a pointer to a SUPER
 446    (i.e., to SUPER's ichain within the ilayout)."
 447
 448   (let* ((class (codegen-class codegen))
 449          (super-head (sod-class-chain-head super)))
 450     (ensure-var codegen "sod__obj"
 451                 (c-type (* (struct (ilayout-struct-tag class))))
 452                 (make-convert-to-ilayout-inst class super-head "me"))))
 453
 454 (export 'make-trampoline)
 455 (defun make-trampoline (codegen super body)
 456   "Construct a trampoline function and return its name.
 457
 458    CODEGEN is a `method-codegen'.  SUPER is a superclass of the CODEGEN
 459    class.  We construct a new trampoline function (with an unimaginative
 460    name) suitable for being passed to a direct method defined on SUPER as its
 461    `next_method'.  In particular, it will have a `me' argument whose type is
 462    pointer-to-SUPER.
 463
 464    The code of the function is generated by BODY, which will be invoked with
 465    a single argument which is the TARGET to which it should deliver its
 466    result.
 467
 468    The return value is the name of the generated function."
 469
 470   (let* ((message (codegen-message codegen))
 471          (message-type (sod-message-type message))
 472          (message-class (sod-message-class message))
 473          (method (codegen-method codegen))
 474          (return-type (c-type-subtype message-type))
 475          (raw-args (sod-message-argument-tail message))
 476          (arguments (cond ((varargs-message-p message)
 477                            (cons (make-argument *sod-ap* c-type-va-list)
 478                                  (butlast raw-args)))
 479                           ((keyword-message-p message)
 480                            (cons (make-argument *sod-key-pointer*
 481                                                 (c-type (* (void :const))))
 482                                  raw-args))))
 483          (*keyword-struct-disposition* (if (effective-method-keywords method)
 484                                            :pointer :null)))
 485     (codegen-push codegen)
 486     (ensure-ilayout-var codegen super)
 487     (when (keyword-message-p message)
 488       (if (eq *keyword-struct-disposition* :null)
 489           (deliver-call codegen :void "SOD__IGNORE" *sod-key-pointer*)
 490           (let ((tag (effective-method-keyword-struct-tag method)))
 491             (ensure-var codegen *sod-keywords*
 492                         (c-type (* (struct tag :const)))
 493                         *sod-key-pointer*))))
 494     (funcall body (codegen-target codegen))
 495     (codegen-pop-function codegen (temporary-function)
 496                           (c-type (fun (lisp return-type)
 497                                        ("me" (* (class super)))
 498                                        . arguments))
 499                           "Delegation-chain trampoline ~:_~
 500                            for `~A.~A' ~:_on `~A'."
 501                           (sod-class-nickname message-class)
 502                           (sod-message-name message)
 503                           (effective-method-class method))))
 504
 505 ;;;--------------------------------------------------------------------------
 506 ;;; Method entry protocol.
 507
 508 (export 'effective-method-function-name)
 509 (defgeneric effective-method-function-name (method)
 510   (:documentation
 511    "Returns the function name of an effective method."))
 512
 513 (export 'method-entry-function-name)
 514 (defgeneric method-entry-function-name (method chain-head role)
 515   (:documentation
 516    "Returns the function name of a method entry.
 517
 518    The method entry is given as an effective method/chain-head/role triple,
 519    rather than as a method entry object because we want the function name
 520    before we've made the entry object."))
 521
 522 (export 'compute-method-entry-functions)
 523 (defgeneric compute-method-entry-functions (method)
 524   (:documentation
 525    "Construct method entry functions.
 526
 527    Builds the effective method function (if there is one) and the necessary
 528    method entries.  Returns a list of functions (i.e., `function-inst'
 529    objects) which need to be defined in the generated source code."))
 530
 531 ;;;--------------------------------------------------------------------------
 532 ;;; Invoking direct methods.
 533
 534 (export 'invoke-delegation-chain)
 535 (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
 536   "Invoke a chain of delegating methods.
 537
 538    CODEGEN is a `method-codegen'.  BASIC-TAIL is a list of argument
 539    expressions to provide to the methods.  The result of the delegation chain
 540    will be delivered to TARGET.
 541
 542    The CHAIN is a list of method objects (it's intended to be used with
 543    `delegating-direct-method' objects).  The behaviour is as follows.  The
 544    first method in the chain is invoked with the necessary arguments (see
 545    below) including a `next_method' pointer.  If KERNEL is nil and there are
 546    no more methods in the chain then the `next_method' pointer will be null;
 547    otherwise it will point to a `trampoline' function, whose behaviour is to
 548    call the remaining methods on the chain as a delegation chain.  The method
 549    may choose to call this function with its arguments.  It will finally
 550    return a value, which will be delivered to the TARGET.
 551
 552    If the chain is empty, then the code generated by KERNEL (given a TARGET
 553    argument) will be invoked.  It is an error if both CHAIN and KERNEL are
 554    nil."
 555
 556   (let* ((message (codegen-message codegen))
 557          (argument-tail (if (varargs-message-p message)
 558                             (cons *sod-tmp-ap* basic-tail)
 559                             basic-tail)))
 560     (labels ((next-trampoline (method chain)
 561                (if (or kernel chain)
 562                    (make-trampoline codegen (sod-method-class method)
 563                                     (lambda (target)
 564                                       (invoke chain target)))
 565                    *null-pointer*))
 566              (invoke (chain target)
 567                (if (null chain)
 568                    (funcall kernel target)
 569                    (let ((trampoline (next-trampoline (car chain)
 570                                                       (cdr chain)))
 571                          (tail (if (keyword-message-p message)
 572                                    (cons (keyword-struct-pointer)
 573                                          argument-tail)
 574                                    argument-tail)))
 575                      (invoke-method codegen target
 576                                     (cons trampoline tail)
 577                                     (car chain))))))
 578       (invoke chain target))))
 579
 580 ;;;----- That's all, folks --------------------------------------------------