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 "&sod__obj.~A.~A"
 386                                   (sod-class-nickname
 387                                    (sod-class-chain-head class))
 388                                   (sod-class-nickname class))
 389                           arguments-tail)))
 390     (if (varargs-message-p message)
 391         (convert-stmts codegen target
 392                        (c-type-subtype (sod-method-type direct-method))
 393                        (lambda (var)
 394                          (ensure-var codegen *sod-ap* (c-type va-list))
 395                          (emit-inst codegen
 396                                     (make-va-copy-inst *sod-ap*
 397                                                        *sod-master-ap*))
 398                          (deliver-expr codegen var
 399                                        (make-call-inst function arguments))
 400                          (emit-inst codegen
 401                                     (make-va-end-inst *sod-ap*))))
 402         (deliver-expr codegen target (make-call-inst function arguments)))))
 403
 404 (definst convert-to-ilayout (stream) (class chain-head expr)
 405   (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
 406           class (sod-class-nickname chain-head) expr))
 407
 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 (defun make-trampoline (codegen super body)
 423   "Construct a trampoline function and return its name.
 424
 425    CODEGEN is a METHOD-CODEGEN.  SUPER is a superclass of the CODEGEN class.
 426    We construct a new trampoline function (with an unimaginative name)
 427    suitable for being passed to a direct method defined on SUPER as its
 428    `next_method'.  In particular, it will have a `me' argument whose type is
 429    pointer-to-SUPER.
 430
 431    The code of the function is generated by BODY, which will be invoked with
 432    a single argument which is the TARGET to which it should deliver its
 433    result.
 434
 435    The return value is the name of the generated function."
 436
 437   (let* ((message (codegen-message codegen))
 438          (message-type (sod-message-type message))
 439          (return-type (c-type-subtype message-type))
 440          (arguments (mapcar (lambda (arg)
 441                               (if (eq (argument-name arg) *sod-ap*)
 442                                   (make-argument *sod-master-ap*
 443                                                  (c-type va-list))
 444                                   arg))
 445                             (sod-message-no-varargs-tail message))))
 446     (codegen-push codegen)
 447     (ensure-ilayout-var codegen super)
 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
 454 (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
 455   "Invoke a chain of delegating methods.
 456
 457    CODEGEN is a METHOD-CODEGEN.  BASIC-TAIL is a list of argument expressions
 458    to provide to the methods.  The result of the delegation chain will be
 459    delivered to TARGET.
 460
 461    The CHAIN is a list of DELEGATING-DIRECT-METHOD objects.  The behaviour is
 462    as follows.  The first method in the chain is invoked with the necessary
 463    arguments (see below) including a `next_method' pointer.  If KERNEL is nil
 464    and there are no more methods in the chain then the `next_method' pointer
 465    will be null; otherwise it will point to a `trampoline' function, whose
 466    behaviour is to call the remaining methods on the chain as a delegation
 467    chain.  The method may choose to call this function with its arguments.
 468    It will finally return a value, which will be delivered to the TARGET.
 469
 470    If the chain is empty, then the code generated by KERNEL (given a TARGET
 471    argument) will be invoked.  It is an error if both CHAIN and KERNEL are
 472    nil."
 473
 474   (let* ((message (codegen-message codegen))
 475          (argument-tail (if (varargs-message-p message)
 476                             (cons *sod-master-ap* basic-tail)
 477                             basic-tail)))
 478     (labels ((next-trampoline (method chain)
 479                (if (or kernel chain)
 480                    (make-trampoline codegen (sod-method-class method)
 481                                     (lambda (target)
 482                                       (invoke chain target)))
 483                    0))
 484              (invoke (chain target)
 485                (if (null chain)
 486                    (funcall kernel target)
 487                    (let* ((trampoline (next-trampoline (car chain)
 488                                                        (cdr chain))))
 489                      (invoke-method codegen target
 490                                     (cons trampoline argument-tail)
 491                                     (car chain))))))
 492       (invoke chain target))))
 493
 494 (defun basic-effective-method-body (codegen target method body)
 495   "Build the common method-invocation structure.
 496
 497    Writes to CODEGEN some basic method-invocation instructions.  It invokes
 498    the `around' methods, from most- to least-specific.  If they all delegate,
 499    then the `before' methods are run, most-specific first; next, the
 500    instructions generated by BODY (invoked with a target argument); then, the
 501    `after' methods are run, least-specific first; and, finally, the value
 502    delivered by the BODY is returned to the `around' methods.  The result
 503    returned by the outermost `around' method -- or, if there are none,
 504    delivered by the BODY -- is finally delivered to the TARGET."
 505
 506   (with-slots (message class before-methods after-methods around-methods)
 507       method
 508     (let* ((message-type (sod-message-type message))
 509            (return-type (c-type-subtype message-type))
 510            (voidp (eq return-type (c-type void)))
 511            (basic-tail (effective-method-basic-argument-names method)))
 512       (flet ((method-kernel (target)
 513                (dolist (before before-methods)
 514                  (invoke-method codegen :void basic-tail before))
 515                (if (or voidp (null after-methods))
 516                    (funcall body target)
 517                    (convert-stmts codegen target return-type
 518                                   (lambda (target)
 519                                     (funcall body target)
 520                                     (dolist (after (reverse after-methods))
 521                                       (invoke-method codegen :void
 522                                                      after basic-tail)))))))
 523         (invoke-delegation-chain codegen target basic-tail
 524                                  around-methods #'method-kernel)))))
 525
 526 ;;;--------------------------------------------------------------------------
 527 ;;; Effective method entry points.
 528
 529 (defgeneric compute-method-entry-functions (method)
 530   (:documentation
 531    "Construct method entry functions.
 532
 533    Builds the effective method function (if there is one) and the necessary
 534    method entries.  Returns a list of functions (i.e., FUNCTION-INST objects)
 535    which need to be defined in the generated source code."))
 536
 537 (defparameter *method-entry-inline-threshold* 200
 538   "Threshold below which effective method bodies are inlined into entries.
 539
 540    After the effective method body has been computed, we calculate its
 541    metric, multiply by the number of entries we need to generate, and compare
 542    it with this threshold.  If the metric is below the threshold then we
 543    fold the method body into the entry functions; otherwise we split the
 544    effective method out into its own function.")
 545
 546 (defgeneric effective-method-function-name (method)
 547   (:documentation
 548    "Returns the function name of an effective method."))
 549
 550 (defgeneric method-entry-function-name (method chain-head)
 551   (:documentation
 552    "Returns the function name of a method entry.
 553
 554    The method entry is given as an effective method/chain-head pair, rather
 555    than as a method entry object because we want the function name before
 556    we've made the entry object."))
 557
 558 (defmethod effective-method-function-name ((method effective-method))
 559   (let* ((class (effective-method-class method))
 560          (message (effective-method-message method))
 561          (message-class (sod-message-class message)))
 562     (format nil "~A__emethod_~A__~A"
 563             class
 564             (sod-class-nickname message-class)
 565             (sod-message-name message))))
 566
 567 (defmethod method-entry-function-name
 568     ((method effective-method) (chain-head sod-class))
 569   (let* ((class (effective-method-class method))
 570          (message (effective-method-message method))
 571          (message-class (sod-message-class message)))
 572     (format nil "~A__mentry_~A__~A__chain_~A"
 573             class
 574             (sod-class-nickname message-class)
 575             (sod-message-name message)
 576             (sod-class-nickname chain-head))))
 577
 578 (defmethod compute-method-entry-functions ((method basic-effective-method))
 579
 580   ;; OK, there's quite a lot of this, so hold tight.
 581   ;;
 582   ;; The first thing we need to do is find all of the related objects.  This
 583   ;; is a bit verbose but fairly straightforward.
 584   ;;
 585   ;; Next, we generate the effective method body -- using COMPUTE-EFFECTIVE-
 586   ;; METHOD-BODY of all things.  This gives us the declarations and body for
 587   ;; an effective method function, but we don't have an actual function yet.
 588   ;;
 589   ;; Now we look at the chains which are actually going to need a method
 590   ;; entry: only those chains whose tail (most specific) class is a
 591   ;; superclass of the class which defined the message need an entry.  We
 592   ;; build a list of these tail classes.
 593   ;;
 594   ;; Having done this, we decide whether it's better to generate a standalone
 595   ;; effective-method function and call it from each of the method entries,
 596   ;; or to inline the effective method body into each of the entries.
 597   ;;
 598   ;; Most of the complexity here comes from (a) dealing with the two
 599   ;; different strategies for constructing method entry functions and (b)
 600   ;; (unsurprisingly) the mess involved with dealing with varargs messages.
 601
 602   (let* ((message (effective-method-message method))
 603          (class (effective-method-class method))
 604          (message-class (sod-message-class message))
 605          (return-type (c-type-subtype (sod-message-type message)))
 606          (codegen (make-instance 'method-codegen
 607                                  :message message
 608                                  :class class
 609                                  :method method))
 610
 611          ;; Effective method function details.
 612          (emf-name (effective-method-function-name method))
 613          (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
 614          (emf-arg-tail (mapcar (lambda (arg)
 615                                  (if (eq (argument-name arg) *sod-ap*)
 616                                      (make-argument *sod-master-ap*
 617                                                     (c-type va-list))
 618                                      arg))
 619                                (sod-message-no-varargs-tail message)))
 620          (emf-type (c-type (fun (lisp return-type)
 621                                 ("sod__obj" (lisp ilayout-type))
 622                                 . (sod-message-no-varargs-tail message))))
 623          (result (if (eq return-type (c-type void)) nil
 624                      (temporary-var codegen return-type)))
 625          (emf-target (or result :void))
 626
 627          ;; Method entry details.
 628          (chain-tails (remove-if-not (lambda (super)
 629                                        (sod-subclass-p super message-class))
 630                                      (mapcar #'car
 631                                              (sod-class-chains class))))
 632          (n-entries (length chain-tails))
 633          (entry-args (sod-message-argument-tail message))
 634          (parm-n (do ((prev "me" (car args))
 635                       (args entry-args (cdr args)))
 636                      ((endp args) nil)
 637                    (when (eq (car args) :ellipsis)
 638                      (return prev))))
 639          (entry-target (codegen-target codegen)))
 640
 641     (labels ((setup-entry (tail)
 642                (let ((head (sod-class-chain-head tail)))
 643                  (codegen-push codegen)
 644                  (ensure-var codegen "sod__obj" ilayout-type
 645                              (make-convert-to-ilayout-inst class
 646                                                            head "me"))))
 647              (varargs-prologue ()
 648                (ensure-var codegen *sod-master-ap* (c-type va-list))
 649                (emit-inst codegen
 650                           (make-va-start-inst *sod-master-ap* parm-n)))
 651              (varargs-epilogue ()
 652                (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
 653              (finish-entry (tail)
 654                (let* ((head (sod-class-chain-head tail))
 655                       (name (method-entry-function-name method head))
 656                       (type (c-type (fun (lisp return-type)
 657                                          ("me" (* (class tail)))
 658                                          . entry-args))))
 659                  (codegen-pop-function codegen name type))))
 660
 661       ;; Generate the method body.  We'll work out what to do with it later.
 662       (codegen-push codegen)
 663       (compute-effective-method-body method codegen emf-target)
 664       (multiple-value-bind (vars insts) (codegen-pop codegen)
 665         (cond ((or (= n-entries 1)
 666                    (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
 667                        *method-entry-inline-threshold*))
 668
 669                ;; The effective method body is simple -- or there's only one
 670                ;; of them.  We'll inline the method body into the entry
 671                ;; functions.
 672                (dolist (tail chain-tails)
 673                  (setup-entry tail)
 674                  (dolist (var vars)
 675                    (ensure-var codegen (inst-name var)
 676                                (inst-type var) (inst-init var)))
 677                  (when parm-n (varargs-prologue))
 678                  (emit-insts codegen insts)
 679                  (when parm-n (varargs-epilogue))
 680                  (deliver-expr codegen entry-target result)
 681                  (finish-entry tail)))
 682
 683               (t
 684
 685                ;; The effective method body is complicated and we'd need more
 686                ;; than one copy.  We'll generate an effective method function
 687                ;; and call it a lot.
 688                (codegen-build-function codegen emf-name emf-type vars
 689                 (nconc insts (and result (list (make-return-inst result)))))
 690
 691                (let ((call (make-call-inst emf-name
 692                             (cons "sod__obj" (mapcar #'argument-name
 693                                                      emf-arg-tail)))))
 694                  (dolist (tail chain-tails)
 695                    (setup-entry tail)
 696                    (cond (parm-n
 697                           (varargs-prologue)
 698                           (convert-stmts codegen entry-target return-type
 699                                          (lambda (target)
 700                                            (deliver-expr codegen target call)
 701                                            (varargs-epilogue))))
 702                          (t
 703                           (deliver-expr codegen entry-target call)))
 704                    (finish-entry tail))))))
 705
 706       (codegen-functions codegen))))
 707
 708 (defmethod slot-unbound
 709     (class (method basic-effective-method) (slot-name (eql 'functions)))
 710   (setf (slot-value method 'functions)
 711         (compute-method-entry-functions method)))
 712
 713 (defmethod method-entry-function-type ((entry method-entry))
 714   (let* ((method (method-entry-effective-method entry))
 715          (message (effective-method-message method))
 716          (type (sod-message-type message)))
 717     (c-type (fun (lisp (c-type-subtype type))
 718                  ("me" (* (class (method-entry-chain-tail entry))))
 719                  . (sod-message-argument-tail message)))))
 720
 721 (defmethod make-method-entry ((method basic-effective-method)
 722                               (chain-head sod-class) (chain-tail sod-class))
 723   (make-instance 'method-entry
 724                  :method method
 725                  :chain-head chain-head
 726                  :chain-tail chain-tail))
 727
 728 ;;;--------------------------------------------------------------------------
 729 ;;; Output.
 730
 731 (defmethod add-output-hooks progn
 732     ((method basic-effective-method) (reason (eql :c)) sequencer)
 733   (with-slots (class functions) method
 734     (sequence-output (stream sequencer)
 735       ((class :effective-methods)
 736        (dolist (func functions)
 737          (write func :stream stream :escape nil :circle nil))))))
 738
 739 ;;;----- That's all, folks --------------------------------------------------