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