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