chiark - git - mdw - sod/blob - methods.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Infrastructure for effective method generation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 ;;; Function type protocol.
  30
  31 (defgeneric sod-message-argument-tail (message)
  32   (:documentation
  33    "Return the argument tail for the message, with invented argument names.
  34
  35    No `me' argument is prepended; any :ELLIPSIS is left as it is."))
  36
  37 (defgeneric sod-message-no-varargs-tail (message)
  38   (:documentation
  39    "Return the argument tail for the message with :ELLIPSIS substituted.
  40
  41    As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
  42    However, an :ELLIPSIS is replaced by an argument of type `va_list', named
  43    `sod__ap'."))
  44
  45 (defgeneric sod-method-function-type (method)
  46   (:documentation
  47    "Return the C function type for the direct method.
  48
  49    This is called during initialization of a direct method object, and the
  50    result is cached.
  51
  52    A default method is provided (by BASIC-DIRECT-METHOD) which simply
  53    prepends an appropriate `me' argument to the user-provided argument list.
  54    Fancy method classes may need to override this behaviour."))
  55
  56 (defgeneric sod-method-next-method-type (method)
  57   (:documentation
  58    "Return the C function type for the next-method trampoline.
  59
  60    This is called during initialization of a direct method object, and the
  61    result is cached.  It should return a function type, not a pointer type.
  62
  63    A default method is provided (by DELEGATING-DIRECT-METHOD) which should do
  64    the right job.  Very fancy subclasses might need to do something
  65    different."))
  66
  67 (defgeneric sod-method-function-name (method)
  68   (:documentation
  69    "Return the C function name for the direct method."))
  70
  71 (defgeneric method-entry-function-type (entry)
  72   (:documentation
  73    "Return the C function type for a method entry."))
  74
  75 ;;;--------------------------------------------------------------------------
  76 ;;; Message classes.
  77
  78 (defclass basic-message (sod-message)
  79   ((argument-tail :type list :reader sod-message-argument-tail)
  80    (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
  81   (:documentation
  82    "Base class for built-in message classes.
  83
  84    Provides the basic functionality for the built-in method combinations.
  85    This is a separate class so that `special effect' messages can avoid
  86    inheriting its default behaviour.
  87
  88    The function type protocol is implemented on BASIC-MESSAGE using slot
  89    reader methods.  The actual values are computed on demand in methods
  90    defined on SLOT-UNBOUND."))
  91
  92 ;;; Function type protocol.
  93
  94 (defmethod slot-unbound (class
  95                          (message basic-message)
  96                          (slot-name (eql 'argument-tail)))
  97   (let ((seq 0))
  98     (mapcar (lambda (arg)
  99               (if (or (eq arg :ellipsis) (argument-name arg))
 100                   arg
 101                   (make-argument (make-instance 'temporary-argument
 102                                                 :tag (prog1 seq (incf seq)))
 103                                  (argument-type arg))))
 104             (c-function-arguments (sod-message-type message)))))
 105
 106 (defmethod slot-unbound (class
 107                          (message basic-message)
 108                          (slot-name (eql 'no-varargs-tail)))
 109   (mapcar (lambda (arg)
 110             (if (eq arg :ellipsis)
 111                 (make-argument *sod-ap* (c-type va-list))
 112                 arg))
 113           (sod-message-argument-tail message)))
 114
 115 ;;; Method class selection.
 116
 117 (defmethod sod-message-method-class
 118     ((message basic-message) (class sod-class) pset)
 119   (let ((role (get-property pset :role :keyword nil)))
 120     (case role
 121       ((:before :after) 'daemon-direct-method)
 122       (:around 'delegating-direct-method)
 123       ((nil) (error "How odd: a primary method slipped through the net"))
 124       (t (error "Unknown method role ~A" role)))))
 125
 126 ;;; Utility functions.
 127
 128 (defun varargs-message-p (message)
 129   "Answer whether the MESSAGE accepts a variable-length argument list.
 130
 131    We need to jump through some extra hoops in order to cope with varargs
 132    messages, so this is useful to know."
 133   (member :ellipsis (sod-message-argument-tail message)))
 134
 135 ;;;--------------------------------------------------------------------------
 136 ;;; Direct method classes.
 137
 138 (defclass basic-direct-method (sod-method)
 139   ((role :initarg :role :type symbol :reader sod-method-role)
 140    (function-type :type c-function-type :reader sod-method-function-type))
 141   (:documentation
 142    "Base class for built-in direct method classes.
 143
 144    Provides the basic functionality for the built-in direct-method classes.
 145    This is a separate class so that `special effect' methods can avoid
 146    inheriting its default behaviour and slots.
 147
 148    A basic method can be assigned a `role', which may be set either as an
 149    initarg or using the :ROLE property.  Roles are used for method
 150    categorization.
 151
 152    The function type protocol is implemented on BASIC-DIRECT-METHOD using
 153    slot reader methods.  The actual values are computed on demand in methods
 154    defined on SLOT-UNBOUND."))
 155
 156 (defmethod shared-initialize :after
 157     ((method basic-direct-method) slot-names &key pset)
 158   (declare (ignore slot-names))
 159   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 160
 161 (defmethod slot-unbound
 162     (class (method basic-direct-method) (slot-name (eql 'function-type)))
 163   (let ((type (sod-method-type method)))
 164     (setf (slot-value method 'function-type)
 165           (c-type (fun (lisp (c-type-subtype type))
 166                        ("me" (* (class (sod-method-class method))))
 167                        . (c-function-arguments type))))))
 168
 169 (defmethod sod-method-function-name ((method basic-direct-method))
 170   (with-slots (class role message) method
 171     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
 172             (sod-class-nickname (sod-message-class message))
 173             (sod-message-name message))))
 174
 175 (defclass daemon-direct-method (basic-direct-method)
 176   ()
 177   (:documentation
 178    "A daemon direct method is invoked for side effects and cannot override.
 179
 180    This is the direct method class for `before' and `after' methods, which
 181    cannot choose to override the remaining methods and are not involved in
 182    the computation of the final result.
 183
 184    In C terms, a daemon method must return `void', and is not passed a
 185    `next_method' pointer."))
 186
 187 (defmethod check-method-type
 188     ((method daemon-direct-method)
 189      (message sod-message)
 190      (type c-function-type))
 191   (with-slots ((msgtype type)) message
 192     (unless (c-type-equal-p (c-type-subtype type) (c-type void))
 193       (error "Method return type ~A must be `void'" (c-type-subtype type)))
 194     (unless (argument-lists-compatible-p (c-function-arguments msgtype)
 195                                          (c-function-arguments type))
 196       (error "Method arguments ~A don't match message ~A" type msgtype))))
 197
 198 (defclass delegating-direct-method (basic-direct-method)
 199   ((next-method-type :type c-function-type
 200                      :reader sod-method-next-method-type))
 201   (:documentation
 202    "A delegating direct method can choose to override other methods.
 203
 204    This is the direct method class for `around' and standard-method-
 205    combination primary methods, which are given the choice of computing the
 206    entire method's result or delegating to (usually) less-specific methods.
 207
 208    In C terms, a delegating method is passed a `next_method' pointer so that
 209    it can delegate part of its behaviour.  (A delegating direct method for a
 210    varargs message is also given an additional `va_list' argument,
 211    conventionally named `sod__ap_master', which it is expected to pass on to
 212    its `next_method' function if necessary.)
 213
 214    The function type protocol is implemented on DELEGATING-DIRECT-METHOD
 215    using slot reader methods.  The actual values are computed on demand in
 216    methods defined on SLOT-UNBOUND."))
 217
 218 (defmethod slot-unbound (class
 219                          (method delegating-direct-method)
 220                          (slot-name (eql 'next-method-type)))
 221   (let* ((message (sod-method-message method))
 222          (type (sod-message-type message)))
 223     (setf (slot-value method 'next-method-type)
 224           (c-type (fun (lisp (c-type-subtype type))
 225                        ("me" (* (class (sod-method-class method))))
 226                        . (c-function-arguments type))))))
 227
 228 (defmethod slot-unbound (class
 229                          (method delegating-direct-method)
 230                          (slot-name (eql 'function-type)))
 231   (let* ((message (sod-method-message method))
 232          (type (sod-method-type method))
 233          (method-args (c-function-arguments type)))
 234     (setf (slot-value method 'function-type)
 235           (c-type (fun (lisp (c-type-subtype type))
 236                        ("me" (* (class (sod-method-class method))))
 237                        ("next_method" (* (lisp (commentify-function-type
 238                                                 (sod-method-next-method-type
 239                                                  method)))))
 240                        . (if (varargs-message-p message)
 241                              (cons (make-argument *sod-master-ap*
 242                                                   (c-type va-list))
 243                                    method-args)
 244                              method-args))))))
 245
 246 ;;;--------------------------------------------------------------------------
 247 ;;; Effective method classes.
 248
 249 (defgeneric effective-method-basic-argument-names (method)
 250   (:documentation
 251    "Return a list of argument names to be passed to direct methods.
 252
 253    The argument names are constructed from the message's arguments returned
 254    by SOD-MESSAGE-NO-VARARGS-TAIL.  The basic arguments are the ones
 255    immediately derived from the programmer's explicitly stated arguments; the
 256    `me' argument is not included, and neither are more exotic arguments added
 257    as part of the method delegation protocol."))
 258
 259 (defclass basic-effective-method (effective-method)
 260   ((around-methods :initarg :around-methods :initform nil
 261                    :type list :reader effective-method-around-methods)
 262    (before-methods :initarg :before-methods :initform nil
 263                    :type list :reader effective-method-before-methods)
 264    (after-methods :initarg :after-methods :initform nil
 265                   :type list :reader effective-method-after-methods)
 266    (basic-argument-names :type list
 267                          :reader effective-method-basic-argument-names)
 268    (functions :type list :reader effective-method-functions))
 269   (:documentation
 270    "Base class for built-in effective method classes.
 271
 272    This class maintains lists of the applicable `before', `after' and
 273    `around' methods and provides behaviour for invoking these methods
 274    correctly.
 275
 276    The argument names protocol is implemented on BASIC-EFFECTIVE-METHOD using
 277    a slot reader method.  The actual values are computed on demand in methods
 278    defined on SLOT-UNBOUND."))
 279
 280 (defmethod slot-unbound (class
 281                          (method basic-effective-method)
 282                          (slot-name (eql 'basic-argument-names)))
 283   (let ((message (effective-method-message method)))
 284     (setf (slot-value method 'basic-argument-names)
 285           (subst *sod-master-ap* *sod-ap*
 286                  (mapcar #'argument-name
 287                          (sod-message-no-varargs-tail message))))))
 288
 289 ;;;--------------------------------------------------------------------------
 290 ;;; Method categorization.
 291
 292 (defmacro categorize ((itemvar items &key bind) categories &body body)
 293   "Categorize ITEMS into lists and invoke BODY.
 294
 295    The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
 296    will contain the current item.  The BIND argument is a list of LET*-like
 297    clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
 298    PREDICATE).
 299
 300    The behaviour of the macro is as follows.  ITEMVAR is assigned (not
 301    bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
 302    CATEGORIES list are evaluated in turn, in an environment containing
 303    ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
 304    At this point, the item is assigned to the category named by the
 305    corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
 306    error is signalled; a PREDICATE consisting only of T will (of course)
 307    match anything; it is detected specially so as to avoid compiler warnings.
 308
 309    Once all of the ITEMS have been categorized in this fashion, the BODY is
 310    evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
 311    variable named after that symbol will be bound in the BODY's environment
 312    to a list of the items in that category, in the same order in which they
 313    were found in the list ITEMS.  The final values of the macro are the final
 314    values of the BODY."
 315
 316   (let* ((cat-names (mapcar #'car categories))
 317          (cat-match-forms (mapcar #'cadr categories))
 318          (cat-vars (mapcar (lambda (name) (gensym (symbol-name name)))
 319                            cat-names))
 320          (items-var (gensym "ITEMS")))
 321     `(let ((,items-var ,items)
 322            ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
 323        (dolist (,itemvar ,items-var)
 324          (let* ,bind
 325            (cond ,@(mapcar (lambda (cat-match-form cat-var)
 326                              `(,cat-match-form
 327                                (push ,itemvar ,cat-var)))
 328                            cat-match-forms cat-vars)
 329                  ,@(and (not (member t cat-match-forms))
 330                         `((t (error "Failed to categorize ~A" ,itemvar)))))))
 331        (let ,(mapcar (lambda (name var)
 332                        `(,name (nreverse ,var)))
 333                      cat-names cat-vars)
 334          ,@body))))
 335
 336 ;;;--------------------------------------------------------------------------
 337 ;;; Code generation.
 338
 339 (defclass method-codegen (codegen)
 340   ((message :initarg :message :type sod-message :reader codegen-message)
 341    (class :initarg :class :type sod-class :reader codegen-class)
 342    (method :initarg :method :type effective-method :reader codegen-method)
 343    (target :initarg :target :reader codegen-target))
 344   (:documentation
 345    "Augments CODEGEN with additional state regarding an effective method.
 346
 347    We store the effective method, and also its target class and owning
 348    message, so that these values are readily available to the code-generating
 349    functions."))
 350
 351 (defmethod shared-initialize :after
 352     ((codegen method-codegen) slot-names &key)
 353   (with-slots (message target) codegen
 354     (setf target
 355           (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
 356               :void
 357               :return))))
 358
 359 (defgeneric compute-effective-method-body (method codegen target)
 360   (:documentation
 361    "Generates the body of an effective method.
 362
 363    Writes the function body to the code generator.  It can (obviously)
 364    generate auxiliary functions if it needs to.
 365
 366    The arguments are as specified by the SOD-MESSAGE-NO-VARARGS-TAIL, with an
 367    additional argument `sod__obj' of type pointer-to-ilayout.  The code
 368    should deliver the result (if any) to the TARGET."))
 369
 370 (defun invoke-method (codegen target arguments-tail direct-method)
 371   "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
 372
 373    The code is generated in the context of CODEGEN, which can be any instance
 374    of the CODEGEN class -- it needn't be an instance of METHOD-CODEGEN.  The
 375    DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of argument
 376    expressions), preceded by a `me' argument of type pointer-to-CLASS where
 377    CLASS is the class on which the method was defined.
 378
 379    If the message accepts a variable-length argument list then a copy of the
 380    prevailing master argument pointer is provided in place of the :ELLIPSIS."
 381
 382   (let* ((message (sod-method-message direct-method))
 383          (class (sod-method-class direct-method))
 384          (function (sod-method-function-name direct-method))
 385          (arguments (cons (format nil "(~A *)&sod__obj.~A" class
 386                                   (sod-class-nickname
 387                                    (sod-class-chain-head class)))
 388                           arguments-tail)))
 389     (if (varargs-message-p message)
 390         (convert-stmts codegen target
 391                        (c-type-subtype (sod-method-type direct-method))
 392                        (lambda (var)
 393                          (ensure-var codegen *sod-ap* (c-type va-list))
 394                          (emit-inst codegen
 395                                     (make-va-copy-inst *sod-ap*
 396                                                        *sod-master-ap*))
 397                          (deliver-expr codegen var
 398                                        (make-call-inst function arguments))
 399                          (emit-inst codegen
 400                                     (make-va-end-inst *sod-ap*))))
 401         (deliver-expr codegen target (make-call-inst function arguments)))))
 402
 403 (definst convert-to-ilayout (stream) (class chain-head expr)
 404   (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
 405           class (sod-class-nickname chain-head) expr))
 406
 407 (defun ensure-ilayout-var (codegen super)
 408   "Define a variable `sod__obj' pointing to the class's ilayout structure.
 409
 410    CODEGEN is a METHOD-CODEGEN.  The class in question is CODEGEN's class,
 411    i.e., the target class for the effective method.  SUPER is one of the
 412    class's superclasses; it is assumed that `me' is a pointer to a SUPER
 413    (i.e., to SUPER's ichain within the ilayout)."
 414
 415   (let* ((class (codegen-class codegen))
 416          (super-head (sod-class-chain-head super)))
 417     (ensure-var codegen "sod__obj"
 418                 (c-type (* (struct (ilayout-struct-tag class))))
 419                 (make-convert-to-ilayout-inst class super-head "me"))))
 420
 421 (defun make-trampoline (codegen super body)
 422   "Construct a trampoline function and return its name.
 423
 424    CODEGEN is a METHOD-CODEGEN.  SUPER is a superclass of the CODEGEN class.
 425    We construct a new trampoline function (with an unimaginative name)
 426    suitable for being passed to a direct method defined on SUPER as its
 427    `next_method'.  In particular, it will have a `me' argument whose type is
 428    pointer-to-SUPER.
 429
 430    The code of the function is generated by BODY, which will be invoked with
 431    a single argument which is the TARGET to which it should deliver its
 432    result.
 433
 434    The return value is the name of the generated function."
 435
 436   (let* ((message (codegen-message codegen))
 437          (message-type (sod-message-type message))
 438          (return-type (c-type-subtype message-type))
 439          (arguments (mapcar (lambda (arg)
 440                               (if (eq (argument-name arg) *sod-ap*)
 441                                   (make-argument *sod-master-ap*
 442                                                  (c-type va-list))
 443                                   arg))
 444                             (sod-message-no-varargs-tail message))))
 445     (codegen-push codegen)
 446     (ensure-ilayout-var codegen super)
 447     (funcall body (codegen-target codegen))
 448     (codegen-pop-function codegen (temporary-function)
 449                           (c-type (fun (lisp return-type)
 450                                        ("me" (* (class super)))
 451                                        . arguments)))))
 452
 453 (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
 454   "Invoke a chain of delegating methods.
 455
 456    CODEGEN is a METHOD-CODEGEN.  BASIC-TAIL is a list of argument expressions
 457    to provide to the methods.  The result of the delegation chain will be
 458    delivered to TARGET.
 459
 460    The CHAIN is a list of DELEGATING-DIRECT-METHOD objects.  The behaviour is
 461    as follows.  The first method in the chain is invoked with the necessary
 462    arguments (see below) including a `next_method' pointer.  If KERNEL is nil
 463    and there are no more methods in the chain then the `next_method' pointer
 464    will be null; otherwise it will point to a `trampoline' function, whose
 465    behaviour is to call the remaining methods on the chain as a delegation
 466    chain.  The method may choose to call this function with its arguments.
 467    It will finally return a value, which will be delivered to the TARGET.
 468
 469    If the chain is empty, then the code generated by KERNEL (given a TARGET
 470    argument) will be invoked.  It is an error if both CHAIN and KERNEL are
 471    nil."
 472
 473   (let* ((message (codegen-message codegen))
 474          (argument-tail (if (varargs-message-p message)
 475                             (cons *sod-master-ap* basic-tail)
 476                             basic-tail)))
 477     (labels ((next-trampoline (method chain)
 478                (if (or kernel chain)
 479                    (make-trampoline codegen (sod-method-class method)
 480                                     (lambda (target)
 481                                       (invoke chain target)))
 482                    0))
 483              (invoke (chain target)
 484                (if (null chain)
 485                    (funcall kernel target)
 486                    (let* ((trampoline (next-trampoline (car chain)
 487                                                        (cdr chain))))
 488                      (invoke-method codegen target
 489                                     (cons trampoline argument-tail)
 490                                     (car chain))))))
 491       (invoke chain target))))
 492
 493 (defun basic-effective-method-body (codegen target method body)
 494   "Build the common method-invocation structure.
 495
 496    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 497    the `around' methods, from most- to least-specific.  If they all delegate,
 498    then the `before' methods are run, most-specific first; next, the
 499    instructions generated by BODY (invoked with a target argument); then, the
 500    `after' methods are run, least-specific first; and, finally, the value
 501    delivered by the BODY is returned to the `around' methods.  The result
 502    returned by the outermost `around' method -- or, if there are none,
 503    delivered by the BODY -- is finally delivered to the TARGET."
 504
 505   (with-slots (message class before-methods after-methods around-methods)
 506       method
 507     (let* ((message-type (sod-message-type message))
 508            (return-type (c-type-subtype message-type))
 509            (voidp (eq return-type (c-type void)))
 510            (basic-tail (effective-method-basic-argument-names method)))
 511       (flet ((method-kernel (target)
 512                (dolist (before before-methods)
 513                  (invoke-method codegen :void basic-tail before))
 514                (if (or voidp (null after-methods))
 515                    (funcall body target)
 516                    (convert-stmts codegen target return-type
 517                                   (lambda (target)
 518                                     (funcall body target)
 519                                     (dolist (after (reverse after-methods))
 520                                       (invoke-method codegen :void
 521                                                      after basic-tail)))))))
 522         (invoke-delegation-chain codegen target basic-tail
 523                                  around-methods #'method-kernel)))))
 524
 525 ;;;--------------------------------------------------------------------------
 526 ;;; Effective method entry points.
 527
 528 (defgeneric compute-method-entry-functions (method)
 529   (:documentation
 530    "Construct method entry functions.
 531
 532    Builds the effective method function (if there is one) and the necessary
 533    method entries.  Returns a list of functions (i.e., FUNCTION-INST objects)
 534    which need to be defined in the generated source code."))
 535
 536 (defparameter *method-entry-inline-threshold* 20
 537   "Threshold below which effective method bodies are inlined into entries.
 538
 539    After the effective method body has been computed, we calculate its
 540    metric, multiply by the number of entries we need to generate, and compare
 541    it with this threshold.  If the metric is below the threshold then we
 542    fold the method body into the entry functions; otherwise we split the
 543    effective method out into its own function.")
 544
 545 (defgeneric effective-method-function-name (method)
 546   (:documentation
 547    "Returns the function name of an effective method."))
 548
 549 (defgeneric method-entry-function-name (method chain-head)
 550   (:documentation
 551    "Returns the function name of a method entry.
 552
 553    The method entry is given as an effective method/chain-head pair, rather
 554    than as a method entry object because we want the function name before
 555    we've made the entry object."))
 556
 557 (defmethod effective-method-function-name ((method effective-method))
 558   (let* ((class (effective-method-class method))
 559          (message (effective-method-message method))
 560          (message-class (sod-message-class message)))
 561     (format nil "~A__emethod_~A__~A"
 562             class
 563             (sod-class-nickname message-class)
 564             (sod-message-name message))))
 565
 566 (defmethod method-entry-function-name
 567     ((method effective-method) (chain-head sod-class))
 568   (let* ((class (effective-method-class method))
 569          (message (effective-method-message method))
 570          (message-class (sod-message-class message)))
 571     (format nil "~A__mentry_~A__~A__~A"
 572             class
 573             (sod-class-nickname message-class)
 574             (sod-message-name message)
 575             (sod-class-nickname chain-head))))
 576
 577 (defmethod compute-method-entry-functions ((method basic-effective-method))
 578
 579   ;; OK, there's quite a lot of this, so hold tight.
 580   ;;
 581   ;; The first thing we need to do is find all of the related objects.  This
 582   ;; is a bit verbose but fairly straightforward.
 583   ;;
 584   ;; Next, we generate the effective method body -- using COMPUTE-EFFECTIVE-
 585   ;; METHOD-BODY of all things.  This gives us the declarations and body for
 586   ;; an effective method function, but we don't have an actual function yet.
 587   ;;
 588   ;; Now we look at the chains which are actually going to need a method
 589   ;; entry: only those chains whose tail (most specific) class is a
 590   ;; superclass of the class which defined the message need an entry.  We
 591   ;; build a list of these tail classes.
 592   ;;
 593   ;; Having done this, we decide whether it's better to generate a standalone
 594   ;; effective-method function and call it from each of the method entries,
 595   ;; or to inline the effective method body into each of the entries.
 596   ;;
 597   ;; Most of the complexity here comes from (a) dealing with the two
 598   ;; different strategies for constructing method entry functions and (b)
 599   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 600
 601   (let* ((message (effective-method-message method))
 602          (class (effective-method-class method))
 603          (message-class (sod-message-class message))
 604          (return-type (c-type-subtype (sod-message-type message)))
 605          (codegen (make-instance 'method-codegen
 606                                  :message message
 607                                  :class class
 608                                  :method method))
 609
 610          ;; Effective method function details.
 611          (emf-name (effective-method-function-name method))
 612          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 613          (emf-arg-tail (mapcar (lambda (arg)
 614                                  (if (eq (argument-name arg) *sod-ap*)
 615                                      (make-argument *sod-master-ap*
 616                                                     (c-type va-list))
 617                                      arg))
 618                                (sod-message-no-varargs-tail message)))
 619          (emf-type (c-type (fun (lisp return-type)
 620                                 ("sod__obj" (lisp ilayout-type))
 621                                 . (sod-message-no-varargs-tail message))))
 622          (result (if (eq return-type (c-type void)) nil
 623                      (temporary-var codegen return-type)))
 624          (emf-target (or result :void))
 625
 626          ;; Method entry details.
 627          (chain-tails (remove-if-not (lambda (super)
 628                                        (sod-subclass-p super message-class))
 629                                      (mapcar #'car
 630                                              (sod-class-chains class))))
 631          (n-entries (length chain-tails))
 632          (entry-args (sod-message-argument-tail message))
 633          (parm-n (do ((prev "me" (car args))
 634                       (args entry-args (cdr args)))
 635                      ((endp args) nil)
 636                    (when (eq (car args) :ellipsis)
 637                      (return prev))))
 638          (entry-target (codegen-target codegen)))
 639
 640     (labels ((setup-entry (tail)
 641                (let ((head (sod-class-chain-head tail)))
 642                  (codegen-push codegen)
 643                  (ensure-var codegen "sod__obj" ilayout-type
 644                              (make-convert-to-ilayout-inst class
 645                                                            head "me"))))
 646              (varargs-prologue ()
 647                (ensure-var codegen *sod-master-ap* (c-type va-list))
 648                (emit-inst codegen
 649                           (make-va-start-inst *sod-master-ap* parm-n)))
 650              (varargs-epilogue ()
 651                (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
 652              (finish-entry (tail)
 653                (let* ((head (sod-class-chain-head tail))
 654                       (name (method-entry-function-name method head))
 655                       (type (c-type (fun (lisp return-type)
 656                                          ("me" (* (class tail)))
 657                                          . entry-args))))
 658                  (codegen-pop-function codegen name type))))
 659
 660       ;; Generate the method body.  We'll work out what to do with it later.
 661       (codegen-push codegen)
 662       (compute-effective-method-body method codegen emf-target)
 663       (multiple-value-bind (vars insts) (codegen-pop codegen)
 664         (cond ((or (= n-entries 1)
 665                    (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 666                        *method-entry-inline-threshold*))
 667
 668                ;; The effective method body is simple -- or there's only one
 669                ;; of them.  We'll inline the method body into the entry
 670                ;; functions.
 671                (dolist (tail chain-tails)
 672                  (setup-entry tail)
 673                  (dolist (var vars)
 674                    (ensure-var codegen (inst-name var)
 675                                (inst-type var) (inst-init var)))
 676                  (when parm-n (varargs-prologue))
 677                  (emit-insts codegen insts)
 678                  (when parm-n (varargs-epilogue))
 679                  (deliver-expr codegen entry-target result)
 680                  (finish-entry tail)))
 681
 682               (t
 683
 684                ;; The effective method body is complicated and we'd need more
 685                ;; than one copy.  We'll generate an effective method function
 686                ;; and call it a lot.
 687                (codegen-build-function codegen emf-name emf-type vars
 688                 (nconc insts (and result (list (make-return-inst result)))))
 689
 690                (let ((call (make-call-inst emf-name
 691                             (cons "sod__obj" (mapcar #'argument-name
 692                                                      emf-arg-tail)))))
 693                  (dolist (tail chain-tails)
 694                    (setup-entry tail)
 695                    (cond (parm-n
 696                           (varargs-prologue)
 697                           (convert-stmts codegen entry-target return-type
 698                                          (lambda (target)
 699                                            (deliver-expr codegen target call)
 700                                            (varargs-epilogue))))
 701                          (t
 702                           (deliver-expr codegen entry-target call)))
 703                    (finish-entry tail))))))
 704
 705       (codegen-functions codegen))))
 706
 707 (defmethod slot-unbound
 708     (class (method basic-effective-method) (slot-name (eql 'functions)))
 709   (setf (slot-value method 'functions)
 710         (compute-method-entry-functions method)))
 711
 712 (defmethod method-entry-function-type ((entry method-entry))
 713   (let* ((method (method-entry-effective-method entry))
 714          (message (effective-method-message method))
 715          (type (sod-message-type message)))
 716     (c-type (fun (lisp (c-type-subtype type))
 717                  ("me" (* (class (method-entry-chain-tail entry))))
 718                  . (sod-message-argument-tail message)))))
 719
 720 (defmethod make-method-entry ((method basic-effective-method)
 721                               (chain-head sod-class) (chain-tail sod-class))
 722   (make-instance 'method-entry
 723                  :method method
 724                  :chain-head chain-head
 725                  :chain-tail chain-tail))
 726
 727 ;;;----- That's all, folks --------------------------------------------------