[sod] / src / method-proto.lisp

;;; -*-lisp-*-
;;;
;;; Method combination protocol
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; 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)

;;;--------------------------------------------------------------------------
;;; Effective methods and entries.

(export '(effective-method
          effective-method-message effective-method-class
          effective-method-keywords))
(defclass effective-method ()
  ((message :initarg :message :type sod-message
            :reader effective-method-message)
   (%class :initarg :class :type sod-class :reader effective-method-class)
   (keywords :type list :reader effective-method-keywords))
  (:documentation
   "The behaviour invoked by sending a message to an instance of a class.

   This class describes the behaviour when an instance of CLASS is sent
   MESSAGE.

   This is not a useful class by itself.  Message classes are expected to
   define their own effective-method classes.

   An effective method class may accept a `:direct-methods' initarg, which
   will be a list of applicable methods sorted in most-to-least specific
   order."))

(export 'sod-message-effective-method-class)
(defgeneric sod-message-effective-method-class (message)
  (:documentation
   "Return the effective method class for the given MESSAGE.

   This function is invoked by `compute-sod-effective-method'."))

(export 'primary-method-class)
(defgeneric primary-method-class (message)
  (:documentation
   "Return the name of the primary direct method class for MESSAGE.

   This protocol is used by `simple-message' subclasses."))

(export 'compute-sod-effective-method)
(defgeneric compute-sod-effective-method (message class)
  (:documentation
   "Return the effective method when a CLASS instance receives MESSAGE.

   The default method constructs an instance of the message's chosen
   `sod-message-effective-method-class', passing the MESSAGE, the CLASS and
   the list of applicable methods as initargs to `make-instance'."))

(export 'compute-effective-methods)
(defgeneric compute-effective-methods (class)
  (:documentation
   "Return a list of all of the effective methods needed for CLASS.

   The list needn't be in any particular order."))

(export '(method-entry method-entry-effective-method
          method-entry-chain-head method-entry-chain-tail))
(defclass method-entry ()
  ((%method :initarg :method :type effective-method
            :reader method-entry-effective-method)
   (chain-head :initarg :chain-head :type sod-class
               :reader method-entry-chain-head)
   (chain-tail :initarg :chain-tail :type sod-class
               :reader method-entry-chain-tail)
   (role :initarg :role :type (or keyword null) :reader method-entry-role))
  (:documentation
   "An entry point into an effective method.

   Specifically, this is the entry point to the effective METHOD invoked via
   the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE.
   The CHAIN-TAIL is the most specific class on this chain; this is useful
   because we can reuse the types of method entries from superclasses on
   non-primary chains.

   Each effective method may have several different method entries, because
   an effective method can be called via vtables attached to different
   chains, and such calls will pass instance pointers which point to
   different `ichain' structures within the overall instance layout; it's the
   job of the method entry to adjust the instance pointers correctly for the
   rest of the effective method.

   A vtable can contain more than one entry for the same message.  Such
   entries are distinguished by their roles.  A message always has an entry
   with the `nil role; in addition, a varargs message also has a `:valist'
   role, which accepts a `va_list' argument in place of the variable argument
   listNo other roles are currently defined, though they may be introduced by
   extensions.

   The boundaries between a method entry and the effective method
   is (intentionally) somewhat fuzzy.  In extreme cases, the effective method
   may not exist at all as a distinct entity in the output because its
   content is duplicated in all of the method entry functions.  This is left
   up to the effective method protocol."))

(export 'make-method-entries)
(defgeneric make-method-entries (effective-method chain-head chain-tail)
  (:documentation
   "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called
   via CHAIN-HEAD.

   There is no default method for this function.  (Maybe when the
   effective-method/method-entry output protocol has settled down I'll know
   what a sensible default action would be.)"))

;;;--------------------------------------------------------------------------
;;; Protocol for messages and direct-methods.

(export 'sod-message-argument-tail)
(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."))

(export 'sod-method-function-type)
(defgeneric sod-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."))

(export 'sod-method-next-method-type)
(defgeneric sod-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."))

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

(export 'keyword-message-p)
(defun keyword-message-p (message)
  "Answer whether the MESSAGE accepts a keyword arguments.

   Dealing with keyword messages is rather fiddly, so this is useful to
   know."
  (typep (sod-message-type message) 'c-keyword-function-type))

(export 'varargs-message-p)
(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)))

;;;--------------------------------------------------------------------------
;;; Protocol for effective methods and method entries.

(export 'method-entry-function-type)
(defgeneric method-entry-function-type (entry)
  (:documentation
   "Return the C function type for a method entry."))

(export 'method-entry-slot-name)
(defgeneric method-entry-slot-name (entry)
  (:documentation
   "Return the `vtmsgs' slot name for a method entry.

   The default method indirects through `method-entry-slot-name-by-role'."))

(defgeneric method-entry-slot-name-by-role (entry role name)
  (:documentation "Easier implementation for `method-entry-slot-name'.")
  (:method ((entry method-entry) (role (eql nil)) name) name)
  (:method ((entry method-entry) (role (eql :valist)) name)
    (format nil "~A__v" name)))

(export 'effective-method-basic-argument-names)
(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-argument-tail', with any ellipsis replaced by an explicit
   `va_list' argument.  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."))

(export 'effective-method-live-p)
(defgeneric effective-method-live-p (method)
  (:documentation
   "Returns true if the effective METHOD is live.

   An effective method is `live' if it should actually have proper method entry
   functions associated with it and stored in the class vtable.  The other
   possibility is that the method is `dead', in which case the function
   pointers in the vtable are left null."))

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

;;; Enhanced code-generator class.

(export '(method-codegen codegen-message codegen-class
          codegen-method codegen-target))
(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."))

;;; Protocol.

(export 'compute-effective-method-body)
(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 determined by agreement with the generic function
   `compute-method-entry-functions'; usually this will be as specified by the
   `sod-message-argument-tail', with any variable-argument tail reified to a
   `va_list', and an additional argument `sod__obj' of type pointer-to-
   ilayout.  The code should deliver the result (if any) to the TARGET."))

(export 'simple-method-body)
(defgeneric simple-method-body (method codegen target)
  (:documentation
   "Generate the body of a simple effective method.

   The function is invoked on an effective METHOD, with a CODEGEN to which it
   should emit code delivering the method's value to TARGET."))

;;; Additional instructions.

;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the
;; slot names, because `expr' is exported by our package, and `class' is
;; actually from the `common-lisp' package.
(definst convert-to-ilayout (stream :export t)
    (#1=#:class chain-head #2=#:expr)
  (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
          #1# (sod-class-nickname chain-head) #2#))

;;; Utilities.

(defvar *keyword-struct-disposition* :unset
  "The current state of the keyword structure.

   This can be one of four values.

     * `:unset' -- the top-level default, mostly because I can't leave it
       unbound and write this documentation.  Nothing that matters should see
       this state.

     * `:local' -- the structure itself is in a local variable `sod__kw'.
       This is used in the top-level effective method.

     * `:pointer' -- the structure is pointed to by the local variable
       `sod__kw'.  This is used by delegation-chain trampolines.

     * `:null' -- there is in fact no structure because none of the
       applicable methods actually define any keywords.")

(defun keyword-access (name &optional suffix)
  "Return an lvalue designating a named member of the keyword struct.

   If a non-nil SUFFIX is provided, then the member is named NAMESUFFIX."
  (flet ((mem (op)
           (format nil "~A~A~A~@[~A~]" *sod-keywords* op name suffix)))
    (ecase *keyword-struct-disposition*
      (:local (mem "."))
      (:pointer (mem "->")))))

(let ((kw-addr (format nil "&~A" *sod-keywords*)))
  (defun keyword-struct-pointer ()
    "Return a pointer to the keyword structure."
    (ecase *keyword-struct-disposition*
      (:local kw-addr)
      (:pointer *sod-keywords*)
      (:null *null-pointer*))))

(export 'invoke-method)
(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 argument pointer is provided in place of the `:ellipsis'."

  (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
         (function (sod-method-function-name direct-method))
         (type (sod-method-type direct-method))
         (keywordsp (keyword-message-p message))
         (keywords (and keywordsp (c-function-keywords type)))
         (arguments (append (list (format nil "&sod__obj->~A.~A"
                                          (sod-class-nickname
                                           (sod-class-chain-head class))
                                          (sod-class-nickname class)))
                            arguments-tail
                            (mapcar (lambda (arg)
                                      (let ((name (argument-name arg))
                                            (default (argument-default arg)))
                                        (if default
                                            (make-cond-inst
                                             (keyword-access name
                                                             "__suppliedp")
                                             (keyword-access name)
                                             default)
                                            (keyword-access name))))
                                    keywords))))
    (cond ((varargs-message-p message)
           (convert-stmts codegen target (c-type-subtype type)
                          (lambda (var)
                            (ensure-var codegen *sod-tmp-ap* c-type-va-list)
                            (deliver-call codegen :void "va_copy"
                                          *sod-tmp-ap* *sod-ap*)
                            (apply #'deliver-call codegen var
                                   function arguments)
                            (deliver-call codegen :void "va_end"
                                          *sod-tmp-ap*))))
          (keywords
           (let ((tag (direct-method-suppliedp-struct-tag direct-method)))
             (with-temporary-var (codegen spvar (c-type (struct tag)))
               (dolist (arg keywords)
                 (let ((name (argument-name arg)))
                   (deliver-expr codegen (format nil "~A.~A" spvar name)
                                 (keyword-access name "__suppliedp"))))
               (setf arguments (list* (car arguments) spvar
                                      (cdr arguments)))
               (apply #'deliver-call codegen target function arguments))))
          (t
           (apply #'deliver-call codegen target function arguments)))))

(export 'ensure-ilayout-var)
(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"))))

(export 'make-trampoline)
(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))
         (message-class (sod-message-class message))
         (method (codegen-method codegen))
         (return-type (c-type-subtype message-type))
         (raw-args (sod-message-argument-tail message))
         (arguments (cond ((varargs-message-p message)
                           (cons (make-argument *sod-ap* c-type-va-list)
                                 (butlast raw-args)))
                          ((keyword-message-p message)
                           (cons (make-argument *sod-key-pointer*
                                                (c-type (* (void :const))))
                                 raw-args))))
         (*keyword-struct-disposition* t))
    (codegen-push codegen)
    (ensure-ilayout-var codegen super)
    (when (and (keyword-message-p message)
               (not (eq *keyword-struct-disposition* :null)))
      (let ((tag (effective-method-keyword-struct-tag method)))
        (ensure-var codegen *sod-keywords* (c-type (* (struct tag :const)))
                    *sod-key-pointer*)))
    (funcall body (codegen-target codegen))
    (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)
                                       ("me" (* (class super)))
                                       . arguments))
                          "Delegation-chain trampoline ~:_~
                           for `~A.~A' ~:_on `~A'."
                          (sod-class-nickname message-class)
                          (sod-message-name message)
                          (effective-method-class method))))

;;;--------------------------------------------------------------------------
;;; Method entry protocol.

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

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

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

(export 'compute-method-entry-functions)
(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."))

;;;--------------------------------------------------------------------------
;;; Invoking direct methods.

(export 'invoke-delegation-chain)
(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 method objects (it's intended to be used with
   `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 (cond ((varargs-message-p message)
                               (cons *sod-tmp-ap* basic-tail))
                              ((keyword-message-p message)
                               (cons (keyword-struct-pointer) basic-tail))
                              (t basic-tail))))
    (labels ((next-trampoline (method chain)
               (if (or kernel chain)
                   (make-trampoline codegen (sod-method-class method)
                                    (lambda (target)
                                      (invoke chain target)))
                   *null-pointer*))
             (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))))

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