[sod] / methods.lisp

;;; -*-lisp-*-
;;;
;;; Infrastructure for effective method generation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Function type protocol.

(defgeneric sod-message-argument-tail (message)
  (:documentation
   "Return the argument tail for the message, with invented argument names.

   No `me' argument is prepended; any :ELLIPSIS is left as it is."))

(defgeneric sod-message-no-varargs-tail (message)
  (:documentation
   "Return the argument tail for the message with :ELLIPSIS substituted.

   As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
   However, an :ELLIPSIS is replaced by an argument of type `va_list', named
   `sod__ap'."))

(defgeneric direct-method-function-type (method)
  (:documentation
   "Return the C function type for the direct method.

   This is called during initialization of a direct method object, and the
   result is cached.

   A default method is provided (by BASIC-DIRECT-METHOD) which simply
   prepends an appropriate `me' argument to the user-provided argument list.
   Fancy method classes may need to override this behaviour."))

(defgeneric direct-method-next-method-type (method)
  (:documentation
   "Return the C function type for the next-method trampoline.

   This is called during initialization of a direct method object, and the
   result is cached.  It should return a function type, not a pointer type.

   A default method is provided (by DELEGATING-DIRECT-METHOD) which should do
   the right job.  Very fancy subclasses might need to do something
   different."))

(defgeneric direct-method-function-name (method)
  (:documentation
   "Return the C function name for the direct method."))

;;;--------------------------------------------------------------------------
;;; Message classes.

(defclass basic-message (sod-message)
  ((argument-tail :type list :reader sod-message-argument-tail)
   (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
  (:documentation
   "Base class for built-in message classes.

   Provides the basic functionality for the built-in method combinations.
   This is a separate class so that `special effect' messages can avoid
   inheriting its default behaviour.

   The function type protocol is implemented on BASIC-MESSAGE using slot
   reader methods.  The actual values are computed on demand in methods
   defined on SLOT-UNBOUND."))

;;; Function type protocol.

(defmethod slot-unbound (class
                         (message basic-message)
                         (slot-name (eql 'argument-tail)))
  (let ((seq 0))
    (mapcar (lambda (arg)
              (if (or (eq arg :ellipsis) (argument-name arg))
                  arg
                  (make-argument (make-instance 'temporary-argument
                                                :tag (prog1 seq (incf seq)))
                                 (argument-type arg))))
            (c-function-arguments (sod-message-type message)))))

(defmethod slot-unbound (class
                         (message basic-message)
                         (slot-name (eql 'no-varargs-tail)))
  (mapcar (lambda (arg)
            (if (eq arg :ellipsis)
                (make-argument *sod-ap* (c-type va-list))
                arg))
          (sod-message-argument-tail message)))

;;; Method class selection.

(defmethod sod-message-method-class
    ((message basic-message) (class sod-class) pset)
  (let ((role (get-property pset :role :keyword nil)))
    (case role
      ((:before :after) 'daemon-direct-method)
      (:around 'delegating-direct-method)
      ((nil) (error "How odd: a primary method slipped through the net"))
      (t (error "Unknown method role ~A" role)))))

;;; Utility functions.

(defun varargs-message-p (message)
  "Answer whether the MESSAGE accepts a variable-length argument list.

   We need to jump through some extra hoops in order to cope with varargs
   messages, so this is useful to know."
  (member :ellipsis (sod-message-argument-tail message)))

;;;--------------------------------------------------------------------------
;;; Direct method classes.

(defclass basic-direct-method (sod-method)
  ((role :initarg :role :type symbol :reader sod-method-role)
   (function-type :type c-function-type :reader sod-method-function-type))
  (:documentation
   "Base class for built-in direct method classes.

   Provides the basic functionality for the built-in direct-method classes.
   This is a separate class so that `special effect' methods can avoid
   inheriting its default behaviour and slots.

   A basic method can be assigned a `role', which may be set either as an
   initarg or using the :ROLE property.  Roles are used for method
   categorization.

   The function type protocol is implemented on BASIC-DIRECT-METHOD using
   slot reader methods.  The actual values are computed on demand in methods
   defined on SLOT-UNBOUND."))

(defmethod shared-initialize :after
    ((method basic-direct-method) slot-names &key pset)
  (declare (ignore slot-names))
  (default-slot (method 'role) (get-property pset :role :keyword nil)))

(defmethod slot-unbound
    (class (method basic-direct-method) (slot-name (eql 'function-type)))
  (let ((type (sod-method-type method)))
    (setf (slot-value method 'function-type)
          (c-type (fun (lisp (c-type-subtype type))
                       ("me" (* (class (sod-method-class method))))
                       . (c-function-arguments type))))))

(defmethod direct-method-function-name ((method basic-direct-method))
  (with-slots (class role message) method
    (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
            (sod-class-nickname (sod-message-class message))
            (sod-message-name message))))

(defclass daemon-direct-method (basic-direct-method)
  ()
  (:documentation
   "A daemon direct method is invoked for side effects and cannot override.

   This is the direct method class for `before' and `after' methods, which
   cannot choose to override the remaining methods and are not involved in
   the computation of the final result.

   In C terms, a daemon method must return `void', and is not passed a
   `next_method' pointer."))

(defmethod check-method-type
    ((method daemon-direct-method)
     (message sod-message)
     (type c-function-type))
  (with-slots ((msgtype type)) message
    (unless (c-type-equal-p (c-type-subtype type) (c-type void))
      (error "Method return type ~A must be `void'" (c-type-subtype type)))
    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
                                         (c-function-arguments type))
      (error "Method arguments ~A don't match message ~A" type msgtype))))

(defclass delegating-direct-method (basic-direct-method)
  ((next-method-type :type c-function-type
                     :reader sod-method-next-method-type))
  (:documentation
   "A delegating direct method can choose to override other methods.

   This is the direct method class for `around' and standard-method-
   combination primary methods, which are given the choice of computing the
   entire method's result or delegating to (usually) less-specific methods.

   In C terms, a delegating method is passed a `next_method' pointer so that
   it can delegate part of its behaviour.  (A delegating direct method for a
   varargs message is also given an additional `va_list' argument,
   conventionally named `sod__ap_master', which it is expected to pass on to
   its `next_method' function if necessary.)

   The function type protocol is implemented on DELEGATING-DIRECT-METHOD
   using slot reader methods.  The actual values are computed on demand in
   methods defined on SLOT-UNBOUND."))

(defmethod slot-unbound (class
                         (method delegating-direct-method)
                         (slot-name (eql 'next-method-type)))
  (let* ((message (sod-method-message method))
         (type (sod-message-type message)))
    (setf (slot-value method 'next-method-type)
          (c-type (fun (lisp (c-type-subtype type))
                       ("me" (* (class (sod-method-class method))))
                       . (c-function-arguments type))))))

(defmethod slot-unbound (class
                         (method delegating-direct-method)
                         (slot-name (eql 'function-type)))
  (let* ((message (sod-method-message method))
         (type (sod-method-type method))
         (method-args (c-function-arguments type)))
    (setf (slot-value method 'function-type)
          (c-type (fun (lisp (c-type-subtype type))
                       ("me" (* (class (sod-method-class method))))
                       ("next_method" (* (lisp (commentify-function-type
                                                (sod-method-next-method-type
                                                 method)))))
                       . (if (varargs-message-p message)
                             (cons (make-argument *sod-master-ap*
                                                  (c-type va-list))
                                   method-args)
                             method-args))))))

;;;--------------------------------------------------------------------------
;;; Effective method classes.

(defgeneric effective-method-basic-argument-names (method)
  (:documentation
   "Return a list of argument names to be passed to direct methods.

   The argument names are constructed from the message's arguments returned
   by SOD-MESSAGE-NO-VARARGS-TAIL.  The basic arguments are the ones
   immediately derived from the programmer's explicitly stated arguments; the
   `me' argument is not included, and neither are more exotic arguments added
   as part of the method delegation protocol."))

(defclass basic-effective-method (effective-method)
  ((around-methods :initarg :around-methods :initform nil
                   :type list :reader effective-method-around-methods)
   (before-methods :initarg :before-methods :initform nil
                   :type list :reader effective-method-before-methods)
   (after-methods :initarg :after-methods :initform nil
                  :type list :reader effective-method-after-methods)
   (basic-argument-names :type list
                         :reader effective-method-basic-argument-names)
   (functions :type list :reader effective-method-functions))
  (:documentation
   "Base class for built-in effective method classes.

   This class maintains lists of the applicable `before', `after' and
   `around' methods and provides behaviour for invoking these methods
   correctly.

   The argument names protocol is implemented on BASIC-EFFECTIVE-METHOD using
   a slot reader method.  The actual values are computed on demand in methods
   defined on SLOT-UNBOUND."))

(defmethod slot-unbound (class
                         (method basic-effective-method)
                         (slot-name (eql 'basic-argument-names)))
  (let ((message (effective-method-message method)))
    (setf (slot-value method 'basic-argument-names)
          (subst *sod-master-ap* *sod-ap*
                 (mapcar #'argument-name
                         (sod-message-no-varargs-tail message))))))

;;;--------------------------------------------------------------------------
;;; Method categorization.

(defmacro categorize ((itemvar items &key bind) categories &body body)
  "Categorize ITEMS into lists and invoke BODY.

   The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
   will contain the current item.  The BIND argument is a list of LET*-like
   clauses.  The CATEGORIES are a list of clauses of the form (SYMBOL
   PREDICATE).

   The behaviour of the macro is as follows.  ITEMVAR is assigned (not
   bound), in turn, each item in the list ITEMS.  The PREDICATEs in the
   CATEGORIES list are evaluated in turn, in an environment containing
   ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
   At this point, the item is assigned to the category named by the
   corresponding SYMBOL.  If none of the PREDICATEs returns non-nil then an
   error is signalled; a PREDICATE consisting only of T will (of course)
   match anything; it is detected specially so as to avoid compiler warnings.

   Once all of the ITEMS have been categorized in this fashion, the BODY is
   evaluated as an implicit PROGN.  For each SYMBOL naming a category, a
   variable named after that symbol will be bound in the BODY's environment
   to a list of the items in that category, in the same order in which they
   were found in the list ITEMS.  The final values of the macro are the final
   values of the BODY."

  (let* ((cat-names (mapcar #'car categories))
         (cat-match-forms (mapcar #'cadr categories))
         (cat-vars (mapcar (lambda (name) (gensym (symbol-name name)))
                           cat-names))
         (items-var (gensym "ITEMS")))
    `(let ((,items-var ,items)
           ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
       (dolist (,itemvar ,items-var)
         (let* ,bind
           (cond ,@(mapcar (lambda (cat-match-form cat-var)
                             `(,cat-match-form
                               (push ,itemvar ,cat-var)))
                           cat-match-forms cat-vars)
                 ,@(and (not (member t cat-match-forms))
                        `((t (error "Failed to categorize ~A" ,itemvar)))))))
       (let ,(mapcar (lambda (name var)
                       `(,name (nreverse ,var)))
                     cat-names cat-vars)
         ,@body))))

;;;--------------------------------------------------------------------------
;;; Code generation.

(defclass method-codegen (codegen)
  ((message :initarg :message :type sod-message :reader codegen-message)
   (class :initarg :class :type sod-class :reader codegen-class)
   (method :initarg :method :type effective-method :reader codegen-method)
   (target :initarg :target :reader codegen-target))
  (:documentation
   "Augments CODEGEN with additional state regarding an effective method.

   We store the effective method, and also its target class and owning
   message, so that these values are readily available to the code-generating
   functions."))

(defmethod shared-initialize :after
    ((codegen method-codegen) slot-names &key)
  (with-slots (message target) codegen
    (setf target
          (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
              :void
              :return))))

(defgeneric compute-effective-method-body (method codegen target)
  (:documentation
   "Generates the body of an effective method.

   Writes the function body to the code generator.  It can (obviously)
   generate auxiliary functions if it needs to.

   The arguments are as specified by the SOD-MESSAGE-NO-VARARGS-TAIL, with an
   additional argument `sod__obj' of type pointer-to-ilayout.  The code
   should deliver the result (if any) to the TARGET."))

(defun invoke-method (codegen target arguments-tail direct-method)
  "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.

   The code is generated in the context of CODEGEN, which can be any instance
   of the CODEGEN class -- it needn't be an instance of METHOD-CODEGEN.  The
   DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of argument
   expressions), preceded by a `me' argument of type pointer-to-CLASS where
   CLASS is the class on which the method was defined.

   If the message accepts a variable-length argument list then a copy of the
   prevailing master argument pointer is provided in place of the :ELLIPSIS."

  (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
         (function (direct-method-function-name direct-method))
         (arguments (cons (format nil "(~A *)&sod__obj.~A" class
                                  (sod-class-nickname
                                   (sod-class-chain-head class)))
                          arguments-tail)))
    (if (varargs-message-p message)
        (convert-stmts codegen target
                       (c-type-subtype (sod-method-type direct-method))
                       (lambda (var)
                         (ensure-var codegen *sod-ap* (c-type va-list))
                         (emit-inst codegen
                                    (make-va-copy-inst *sod-ap*
                                                       *sod-master-ap*))
                         (deliver-expr codegen var
                                       (make-call-inst function arguments))
                         (emit-inst codegen
                                    (make-va-end-inst *sod-ap*))))
        (deliver-expr codegen target (make-call-inst function arguments)))))

(definst convert-to-ilayout (stream) (class chain-head expr)
  (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
          class (sod-class-nickname chain-head) expr))

(defun ensure-ilayout-var (codegen super)
  "Define a variable `sod__obj' pointing to the class's ilayout structure.

   CODEGEN is a METHOD-CODEGEN.  The class in question is CODEGEN's class,
   i.e., the target class for the effective method.  SUPER is one of the
   class's superclasses; it is assumed that `me' is a pointer to a SUPER
   (i.e., to SUPER's ichain within the ilayout)."

  (let* ((class (codegen-class codegen))
         (super-head (sod-class-chain-head super)))
    (ensure-var codegen "sod__obj"
                (c-type (* (struct (ilayout-struct-tag class))))
                (make-convert-to-ilayout-inst class super-head "me"))))

(defun make-trampoline (codegen super body)
  "Construct a trampoline function and return its name.

   CODEGEN is a METHOD-CODEGEN.  SUPER is a superclass of the CODEGEN class.
   We construct a new trampoline function (with an unimaginative name)
   suitable for being passed to a direct method defined on SUPER as its
   `next_method'.  In particular, it will have a `me' argument whose type is
   pointer-to-SUPER.

   The code of the function is generated by BODY, which will be invoked with
   a single argument which is the TARGET to which it should deliver its
   result.

   The return value is the name of the generated function."

  (let* ((message (codegen-message codegen))
         (message-type (sod-message-type message))
         (return-type (c-type-subtype message-type))
         (arguments (mapcar (lambda (arg)
                              (if (eq (argument-name arg) *sod-ap*)
                                  (make-argument *sod-master-ap*
                                                 (c-type va-list))
                                  arg))
                            (sod-message-no-varargs-tail message))))
    (codegen-push codegen)
    (ensure-ilayout-var codegen super)
    (funcall body (codegen-target codegen))
    (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)
                                       ("me" (* (class super)))
                                       . arguments))))))

(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
  "Invoke a chain of delegating methods.

   CODEGEN is a METHOD-CODEGEN.  BASIC-TAIL is a list of argument expressions
   to provide to the methods.  The result of the delegation chain will be
   delivered to TARGET.

   The CHAIN is a list of DELEGATING-DIRECT-METHOD objects.  The behaviour is
   as follows.  The first method in the chain is invoked with the necessary
   arguments (see below) including a `next_method' pointer.  If KERNEL is nil
   and there are no more methods in the chain then the `next_method' pointer
   will be null; otherwise it will point to a `trampoline' function, whose
   behaviour is to call the remaining methods on the chain as a delegation
   chain.  The method may choose to call this function with its arguments.
   It will finally return a value, which will be delivered to the TARGET.

   If the chain is empty, then the code generated by KERNEL (given a TARGET
   argument) will be invoked.  It is an error if both CHAIN and KERNEL are
   nil."

  (let* ((message (codegen-message codegen))
         (argument-tail (if (varargs-message-p message)
                            (cons *sod-master-ap* basic-tail)
                            basic-tail)))
    (labels ((next-trampoline (method chain)
               (if (or kernel chain)
                   (make-trampoline codegen (sod-method-class method)
                                    (lambda (target)
                                      (invoke chain target)))
                   0))
             (invoke (chain target)
               (if (null chain)
                   (funcall kernel target)
                   (let* ((trampoline (next-trampoline (car chain)
                                                       (cdr chain))))
                     (invoke-method codegen target
                                    (cons trampoline argument-tail)
                                    (car chain))))))
      (invoke chain target))))

(defun basic-effective-method-body (codegen target method body)
  "Build the common method-invocation structure.

   Writes to CODEGEN some basic method-invocation instructions.  It invokes
   the `around' methods, from most- to least-specific.  If they all delegate,
   then the `before' methods are run, most-specific first; next, the
   instructions generated by BODY (invoked with a target argument); then, the
   `after' methods are run, least-specific first; and, finally, the value
   delivered by the BODY is returned to the `around' methods.  The result
   returned by the outermost `around' method -- or, if there are none,
   delivered by the BODY -- is finally delivered to the TARGET."

  (with-slots (message class before-methods after-methods around-methods)
      method
    (let* ((message-type (sod-message-type message))
           (return-type (c-type-subtype message-type))
           (voidp (eq return-type (c-type void)))
           (basic-tail (effective-method-basic-argument-names method)))
      (flet ((method-kernel (target)
               (dolist (before before-methods)
                 (invoke-method codegen :void basic-tail before))
               (if (or voidp (null after-methods))
                   (funcall body target)
                   (convert-stmts codegen target return-type
                                  (lambda (target)
                                    (funcall body target)
                                    (dolist (after (reverse after-methods))
                                      (invoke-method codegen :void
                                                     after basic-tail)))))))
        (invoke-delegation-chain codegen target basic-tail
                                 around-methods #'method-kernel)))))

;;;--------------------------------------------------------------------------
;;; Effective method entry points.

(defgeneric compute-method-entry-functions (method)
  (:documentation
   "Construct method entry functions.

   Builds the effective method function (if there is one) and the necessary
   method entries.  Returns a list of functions (i.e., FUNCTION-INST objects)
   which need to be defined in the generated source code."))

(defparameter *method-entry-inline-threshold* 20
  "Threshold below which effective method bodies are inlined into entries.

   After the effective method body has been computed, we calculate its
   metric, multiply by the number of entries we need to generate, and compare
   it with this threshold.  If the metric is below the threshold then we
   fold the method body into the entry functions; otherwise we split the
   effective method out into its own function.")

(defgeneric effective-method-function-name (method)
  (:documentation
   "Returns the function name of an effective method."))

(defgeneric method-entry-function-name (method chain-head)
  (:documentation
   "Returns the function name of a method entry.

   The method entry is given as an effective method/chain-head pair, rather
   than as a method entry object because we want the function name before
   we've made the entry object."))

(defmethod effective-method-function-name ((method effective-method))
  (let* ((class (effective-method-class method))
         (message (effective-method-message method))
         (message-class (sod-message-class message)))
    (format nil "~A__emethod_~A__~A"
            class
            (sod-class-nickname message-class)
            (sod-message-name message))))

(defmethod method-entry-function-name
    ((method effective-method) (chain-head sod-class))
  (let* ((class (effective-method-class method))
         (message (effective-method-message method))
         (message-class (sod-message-class message)))
    (format nil "~A__mentry_~A__~A__~A"
            class
            (sod-class-nickname message-class)
            (sod-message-name message)
            (sod-class-nickname chain-head))))

(defmethod compute-method-entry-functions ((method basic-effective-method))

  ;; OK, there's quite a lot of this, so hold tight.
  ;;
  ;; The first thing we need to do is find all of the related objects.  This
  ;; is a bit verbose but fairly straightforward.
  ;;
  ;; Next, we generate the effective method body -- using COMPUTE-EFFECTIVE-
  ;; METHOD-BODY of all things.  This gives us the declarations and body for
  ;; an effective method function, but we don't have an actual function yet.
  ;;
  ;; Now we look at the chains which are actually going to need a method
  ;; entry: only those chains whose tail (most specific) class is a
  ;; superclass of the class which defined the message need an entry.  We
  ;; build a list of these tail classes.
  ;;
  ;; Having done this, we decide whether it's better to generate a standalone
  ;; effective-method function and call it from each of the method entries,
  ;; or to inline the effective method body into each of the entries.
  ;;
  ;; Most of the complexity here comes from (a) dealing with the two
  ;; different strategies for constructing method entry functions and (b)
  ;; (unsurprisingly) the mess involved with dealing with varargs messages.

  (let* ((message (effective-method-message method))
         (class (effective-method-class method))
         (message-class (sod-message-class message))
         (return-type (c-type-subtype (sod-message-type message)))
         (codegen (make-instance 'method-codegen
                                 :message message
                                 :class class
                                 :method method))

         ;; Effective method function details.
         (emf-name (effective-method-function-name method))
         (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
         (emf-arg-tail (mapcar (lambda (arg)
                                 (if (eq (argument-name arg) *sod-ap*)
                                     (make-argument *sod-master-ap*
                                                    (c-type va-list))
                                     arg))
                               (sod-message-no-varargs-tail message)))
         (emf-type (c-type (fun (lisp return-type)
                                ("sod__obj" (lisp ilayout-type))
                                . (sod-message-no-varargs-tail message))))
         (result (if (eq return-type (c-type void)) nil
                     (temporary-var codegen return-type)))
         (emf-target (or result :void))

         ;; Method entry details.
         (chain-tails (remove-if-not (lambda (super)
                                       (sod-subclass-p super message-class))
                                     (mapcar #'car
                                             (sod-class-chains class))))
         (n-entries (length chain-tails))
         (entry-args (sod-message-argument-tail message))
         (parm-n (do ((prev "me" (car args))
                      (args entry-args (cdr args)))
                     ((endp args) nil)
                   (when (eq (car args) :ellipsis)
                     (return prev))))
         (entry-target (codegen-target codegen)))

    (labels ((setup-entry (tail)
               (let ((head (sod-class-chain-head tail)))
                 (codegen-push codegen)
                 (ensure-var codegen "sod__obj" ilayout-type
                             (make-convert-to-ilayout-inst class
                                                           head "me"))))
             (varargs-prologue ()
               (ensure-var codegen *sod-master-ap* (c-type va-list))
               (emit-inst codegen
                          (make-va-start-inst *sod-master-ap* parm-n)))
             (varargs-epilogue ()
               (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
             (finish-entry (tail)
               (let* ((head (sod-class-chain-head tail))
                      (name (method-entry-function-name method head))
                      (type (c-type (fun (lisp return-type)
                                         ("me" (* (class tail)))
                                         . entry-args))))
                 (codegen-pop-function codegen name type))))

      ;; Generate the method body.  We'll work out what to do with it later.
      (codegen-push codegen)
      (compute-effective-method-body method codegen emf-target)
      (multiple-value-bind (vars insts) (codegen-pop codegen)
        (cond ((or (= n-entries 1)
                   (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
                       *method-entry-inline-threshold*))

               ;; The effective method body is simple -- or there's only one
               ;; of them.  We'll inline the method body into the entry
               ;; functions.
               (dolist (tail chain-tails)
                 (setup-entry tail)
                 (dolist (var vars)
                   (ensure-var codegen (inst-name var)
                               (inst-type var) (inst-init var)))
                 (when parm-n (varargs-prologue))
                 (emit-insts codegen insts)
                 (when parm-n (varargs-epilogue))
                 (deliver-expr codegen entry-target result)
                 (finish-entry tail)))

              (t

               ;; The effective method body is complicated and we'd need more
               ;; than one copy.  We'll generate an effective method function
               ;; and call it a lot.
               (codegen-build-function codegen emf-name emf-type vars
                (nconc insts (and result (list (make-return-inst result)))))

               (let ((call (make-call-inst emf-name
                            (cons "sod__obj" (mapcar #'argument-name
                                                     emf-arg-tail)))))
                 (dolist (tail chain-tails)
                   (setup-entry tail)
                   (cond (parm-n
                          (varargs-prologue)
                          (convert-stmts codegen entry-target return-type
                                         (lambda (target)
                                           (deliver-expr codegen target call)
                                           (varargs-epilogue))))
                         (t
                          (deliver-expr codegen entry-target call)))
                   (finish-entry tail))))))

      (codegen-functions codegen))))

(defmethod slot-unbound
    (class (method basic-effective-method) (slot-name (eql 'functions)))
  (setf (slot-value method 'functions)
        (compute-method-entry-functions method)))

(defmethod make-method-entry
    ((method basic-effective-method) (chain-head sod-class))
  (make-instance 'method-entry :method method :chain-head chain-head))

;;;----- That's all, folks --------------------------------------------------