X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa..dea4d05507e59ab779ed4bb209e05971d87e260c:/src/impl-method.lisp

diff --git a/src/impl-method.lisp b/src/impl-method.lisp
new file mode 100644
index 0000000..a1e2a65
--- /dev/null
+++ b/src/impl-method.lisp
@@ -0,0 +1,546 @@
+;;; -*-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 --------------------------------------------------