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