--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Method combination implementation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble 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)
+
+;;;--------------------------------------------------------------------------
+;;; Message classes.
+
+(export 'basic-message)
+(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'."))
+
+(defmethod slot-unbound (class
+ (message basic-message)
+ (slot-name (eql 'argument-tail)))
+ (let ((seq 0))
+ (setf (slot-value message 'argument-tail)
+ (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)))
+ (setf (slot-value message 'no-varargs-tail)
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ (make-argument *sod-ap* (c-type va-list))
+ arg))
+ (sod-message-argument-tail message))))
+
+(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)))))
+
+(export 'simple-message)
+(defclass simple-message (basic-message)
+ ()
+ (:documentation
+ "Base class for messages with `simple' method combinations.
+
+ A simple method combination is one which has only one method role other
+ than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
+ We call these `primary' methods, and the programmer designates them by not
+ specifying an explicit role.
+
+ If the programmer doesn't define any primary methods then the effective
+ method is null -- i.e., the method entry pointer shows up as a null
+ pointer."))
+
+(defmethod sod-message-method-class
+ ((message simple-message) (class sod-class) pset)
+ (if (get-property pset :role :keyword nil)
+ (call-next-method)
+ (primary-method-class message)))
+
+;;;--------------------------------------------------------------------------
+;;; Direct method classes.
+
+(export 'basic-direct-method)
+(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 sod-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))))
+
+(export 'daemon-direct-method)
+(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))))
+
+(export 'delegating-direct-method)
+(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.
+
+(export 'basic-effective-method)
+(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))))))
+
+(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 slot-unbound
+ (class (method basic-effective-method) (slot-name (eql 'functions)))
+ (setf (slot-value method 'functions)
+ (compute-method-entry-functions method)))
+
+(export 'simple-effective-method)
+(defclass simple-effective-method (basic-effective-method)
+ ((primary-methods :initarg :primary-methods :initform nil
+ :type list :reader effective-method-primary-methods))
+ (:documentation
+ "Effective method counterpart to `simple-message'."))
+
+(defmethod shared-initialize :after
+ ((method simple-effective-method) slot-names &key direct-methods)
+ (declare (ignore slot-names))
+ (categorize (method direct-methods :bind ((role (sod-method-role method))))
+ ((primary (null role))
+ (before (eq role :before))
+ (after (eq role :after))
+ (around (eq role :around)))
+ (with-slots (primary-methods before-methods after-methods around-methods)
+ method
+ (setf primary-methods primary
+ before-methods before
+ after-methods (reverse after)
+ around-methods around))))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
+
+(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))))
+
+;;;--------------------------------------------------------------------------
+;;; Invoking direct methods.
+
+(export 'basic-effective-method-body)
+(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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Method entry points.
+
+(defparameter *method-entry-inline-threshold* 200
+ "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.")
+
+(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)))
+ (if (or (not (slot-boundp method 'functions))
+ (slot-value method 'functions))
+ (format nil "~A__mentry_~A__~A__chain_~A"
+ class
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ (sod-class-nickname chain-head))
+ 0)))
+
+(defmethod method-entry-function-type ((entry method-entry))
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
+ (type (sod-message-type message)))
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (* (class (method-entry-chain-tail entry))))
+ . (sod-message-argument-tail message)))))
+
+(defmethod make-method-entry ((method basic-effective-method)
+ (chain-head sod-class) (chain-tail sod-class))
+ (make-instance 'method-entry
+ :method method
+ :chain-head chain-head
+ :chain-tail chain-tail))
+
+(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)))
+
+ (flet ((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 compute-method-entry-functions
+ ((method simple-effective-method))
+ (if (effective-method-primary-methods method)
+ (call-next-method)
+ nil))
+
+(defmethod compute-effective-method-body
+ ((method simple-effective-method) codegen target)
+ (with-slots (message basic-argument-names primary-methods) method
+ (basic-effective-method-body codegen target method
+ (lambda (target)
+ (simple-method-body method
+ codegen
+ target)))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard method combination.
+
+(export 'standard-message)
+(defclass standard-message (simple-message)
+ ()
+ (:documentation
+ "Message class for standard method combination.
+
+ Standard method combination is a simple method combination where the
+ primary methods are invoked as a delegation chain, from most- to
+ least-specific."))
+
+(export 'standard-effective-method)
+(defclass standard-effective-method (simple-effective-method) ()
+ (:documentation "Effective method counterpart to `standard-message'."))
+
+(defmethod primary-method-class ((message standard-message))
+ 'delegating-direct-method)
+
+(defmethod message-effective-method-class ((message standard-message))
+ 'standard-effective-method)
+
+(defmethod simple-method-body
+ ((method standard-effective-method) codegen target)
+ (invoke-delegation-chain codegen
+ target
+ (effective-method-basic-argument-names method)
+ (effective-method-primary-methods method)
+ nil))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff