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

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 49c6676..e1b4980 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -558,4 +558,401 @@
 			   (effective-method-primary-methods method)
 			   nil))
 
+;;;--------------------------------------------------------------------------
+;;; Aggregate method combinations.
+
+(export 'aggregating-message)
+(defclass aggregating-message (simple-message)
+  ((combination :initarg :combination :type keyword
+		:reader message-combination)
+   (kernel-function :type function :reader message-kernel-function))
+  (:documentation
+   "Message class for aggregating method combinations.
+
+   An aggregating method combination invokes the primary methods in order,
+   most-specific first, collecting their return values, and combining them
+   together in some way to produce a result for the effective method as a
+   whole.
+
+   Mostly, this is done by initializing an accumulator to some appropriate
+   value, updating it with the result of each primary method in turn, and
+   finally returning some appropriate output function of it.  The order is
+   determined by the `:most-specific' property, which may have the value
+   `:first' or `:last'.
+
+   The `progn' method combination is implemented as a slightly weird special
+   case of an aggregating method combination with a trivial state.  More
+   typical combinations are `:sum', `:product', `:min', `:max', `:and', and
+   `:or'.  Finally, there's a `custom' combination which uses user-supplied
+   code fragments to stitch everything together."))
+
+(export 'aggregating-message-properties)
+(defgeneric aggregating-message-properties (message combination)
+  (:documentation
+   "Return a description of the properties needed by the method COMBINATION.
+
+   The description should be a plist of alternating property name and type
+   keywords.  The named properties will be looked up in the pset supplied at
+   initialization time, and supplied to `compute-aggregating-message-kernel'
+   as keyword arguments.  Defaults can be supplied in method BVLs.
+
+   The default is not to capture any property values.
+
+   The reason for this is as not to retain the pset beyond message object
+   initialization.")
+  (:method (message combination) nil))
+
+(export 'compute-aggregating-message-kernel)
+(defgeneric compute-aggregating-message-kernel
+    (message combination codegen target methods arg-names &key)
+  (:documentation
+   "Determine how to aggregate the direct methods for an aggregating message.
+
+   The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
+   METHODS): it should emit, to CODEGEN, an appropriate effective-method
+   kernel which invokes the listed direct METHODS, in the appropriate order,
+   collects and aggregates their values, and delivers to TARGET the final
+   result of the method kernel.
+
+   The easy way to implement this method is to use the macro
+   `define-aggregating-method-combination'."))
+
+(defmethod shared-initialize :before
+    ((message aggregating-message) slot-names &key pset)
+  (declare (ignore slot-names))
+  (with-slots (combination kernel-function) message
+    (let ((most-specific (get-property pset :most-specific :keyword :first))
+	  (comb (get-property pset :combination :keyword)))
+
+      ;; Check that we've been given a method combination and make sure it
+      ;; actually exists.
+      (unless comb
+	(error "The `combination' property is required."))
+      (unless (some (lambda (method)
+		      (let* ((specs (method-specializers method))
+			     (message-spec (car specs))
+			     (combination-spec (cadr specs)))
+			(and (typep message-spec 'class)
+			     (typep message message-spec)
+			     (typep combination-spec 'eql-specializer)
+			     (eq (eql-specializer-object combination-spec)
+				 comb))))
+		    (generic-function-methods
+		     #'compute-aggregating-message-kernel))
+	(error "Unknown method combination `~(~A~)'." comb))
+      (setf combination comb)
+
+      ;; Make sure the ordering is actually valid.
+      (unless (member most-specific '(:first :last))
+	(error "The `most_specific' property must be `first' or `last'."))
+
+      ;; Set up the function which will compute the kernel.
+      (let ((magic (cons nil nil))
+	    (keys nil))
+
+	;; Collect the property values wanted by the method combination.
+	(do ((want (aggregating-message-properties message comb)
+		   (cddr want)))
+	    ((endp want))
+	  (let* ((name (car want))
+		 (type (cadr want))
+		 (prop (get-property pset name type magic)))
+	    (unless (eq prop magic)
+	      (setf keys (list* name prop keys)))))
+
+	;; Set the kernel function for later.
+	(setf kernel-function
+	      (lambda (codegen target arg-names methods)
+		(apply #'compute-aggregating-message-kernel
+		       message comb
+		       codegen target
+		       (ecase most-specific
+			 (:first methods)
+			 (:last (setf methods (reverse methods))))
+		       arg-names
+		       keys)))))))
+
+(export 'check-aggregating-message-type)
+(defgeneric check-aggregating-message-type (message combination type)
+  (:documentation
+   "Check that TYPE is an acceptable function TYPE for the COMBINATION.
+
+   For example, `progn' messages must return `void', while `and' and `or'
+   messages must return `int'.")
+  (:method (message combination type)
+    t))
+
+(defmethod check-message-type ((message aggregating-message) type)
+  (with-slots (combination) message
+    (check-aggregating-message-type message combination type)))
+
+(flet ((check (comb want type)
+	 (unless (eq (c-type-subtype type) want)
+	   (error "Messages with `~A' combination must return `~A'."
+		  (string-downcase comb) want))))
+  (defmethod check-aggregating-message-type
+      ((message aggregating-message)
+       (combination (eql :progn))
+       (type c-function-type))
+    (check combination c-type-void type)
+    (call-next-method))
+  (defmethod check-aggregating-message-type
+      ((message aggregating-message)
+       (combination (eql :and))
+       (type c-function-type))
+    (check combination c-type-int type)
+    (call-next-method))
+  (defmethod check-aggregating-message-type
+      ((message aggregating-message)
+       (combination (eql :or))
+       (type c-function-type))
+    (check combination c-type-int type)
+    (call-next-method)))
+
+(export 'define-aggregating-method-combination)
+(defmacro define-aggregating-method-combination
+    (comb
+     (vars
+      &key (codegen (gensym "CODEGEN-"))
+	   (methods (gensym "METHODS-")))
+     &key properties
+	  ((:around around-func) '#'funcall)
+	  ((:first-method first-method-func) nil firstp)
+	  ((:methods methods-func) '#'funcall))
+  "Utility macro for definining aggregating method combinations.
+
+   The VARS are a list of variable names to be bound to temporary variable
+   objects of the method's return type.  Additional keyword arguments define
+   variables names to be bound to other possibly interesting values:
+
+     * CODEGEN is the `codegen' object passed at effective-method computation
+       time; and
+
+     * METHODS is the list of primary methods, in the order in which they
+       should be invoked.  Note that this list must be non-empty, since
+       otherwise the method on `compute-effective-method-body' specialized to
+       `simple-effective-method' will suppress the method entirely.
+
+   The PROPERTIES, if specified, are a list of properties to be collected
+   during message-object initialization; items in the list have the form
+
+	   (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
+
+   similar to a `&key' BVL entry, except for the additional TYPE entry.  In
+   particular, a symbolic NAME may be written in place of a singleton list.
+   The KEYWORD names the property as it should be looked up in the pset,
+   while the NAME names a variable to which the property value or default is
+   bound.
+
+   All of these variables, and the VARS, are available in the functions
+   described below.
+
+   The AROUND, FIRST-METHOD, and METHODS are function designators (probably
+   `lambda' forms) providing pieces of the aggregating behaviour.
+
+   The AROUND function is called first, with a single argument BODY, though
+   the variables above are also in scope.  It is expected to emit code to
+   CODEGEN which invokes the METHODS in the appropriate order, and arranges
+   to store the aggregated return value in the first of the VARS.
+
+   It may call BODY as a function in order to assist with this; let ARGS be
+   the list of arguments supplied to it.  The default behaviour is to call
+   BODY with no arguments.  The BODY function first calls FIRST-METHOD,
+   passing it as arguments a function INVOKE and the ARGS which were passed
+   to BODY, and then calls METHODS once for each remaining method, again
+   passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
+   specified, then the METHODS function is used for all of the methods.  If
+   METHODS is not specified, then the behaviour is simply to call INVOKE
+   immediately.  (See the definition of the `:progn' method combination.)
+
+   Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
+   the appropriate direct method and deliver its return value to TARGET,
+   which defaults to `:void'."
+
+  (with-gensyms (type msg combvar target arg-names args
+		 meth targ func call-methfunc
+		 aroundfunc fmethfunc methfunc)
+    `(progn
+
+       ;; If properties are listed, arrange for them to be collected.
+       ,@(and properties
+	      `((defmethod aggregating-message-properties
+		    ((,msg aggregating-message) (,combvar (eql ',comb)))
+		  ',(mapcan (lambda (prop)
+			      (list (let* ((name (car prop))
+					   (names (if (listp name) name
+						      (list name))))
+				      (if (cddr names) (car names)
+					  (intern (car names) :keyword)))
+				    (cadr prop)))
+			    properties))))
+
+       ;; Define the main kernel-compuation method.
+       (defmethod compute-aggregating-message-kernel
+	   ((,msg aggregating-message) (,combvar (eql ',comb))
+	    ,codegen ,target ,methods ,arg-names
+	    &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
+			   properties))
+	 (declare (ignore ,combvar))
+
+	 ;; Declare the necessary variables and give names to the functions
+	 ;; supplied by the caller.
+	 (let* (,@(and vars
+		       `((,type (c-type-subtype (sod-message-type ,msg)))))
+		,@(mapcar (lambda (var)
+			    (list var `(temporary-var ,codegen ,type)))
+			  vars)
+		(,aroundfunc ,around-func)
+		(,methfunc ,methods-func)
+		(,fmethfunc ,(if firstp first-method-func methfunc)))
+
+	   ;; Arrange to release the temporaries when we're finished with
+	   ;; them.
+	   (unwind-protect
+		(progn
+
+		  ;; Wrap the AROUND function around most of the work.
+		  (funcall ,aroundfunc
+			   (lambda (&rest ,args)
+			     (flet ((,call-methfunc (,func ,meth)
+				      ;; Call FUNC, passing it an INVOKE
+				      ;; function which will generate a call
+				      ;; to METH.
+				      (apply ,func
+					     (lambda
+						 (&optional (,targ :void))
+					       (invoke-method ,codegen
+							      ,targ
+							      ,arg-names
+							      ,meth))
+					     ,args)))
+
+			       ;; The first method might need special
+			       ;; handling.
+			       (,call-methfunc ,fmethfunc (car ,methods))
+
+			       ;; Call the remaining methods in the right
+			       ;; order.
+			       (dolist (,meth (cdr ,methods))
+				 (,call-methfunc ,methfunc ,meth)))))
+
+		  ;; Outside the AROUND function now, deliver the final
+		  ;; result to the right place.
+		  (deliver-expr ,codegen ,target ,(car vars)))
+
+	     ;; Finally, release the temporary variables.
+	     ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
+		       vars))))
+
+       ',comb)))
+
+(define-aggregating-method-combination :progn (nil))
+
+(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
+  :first-method (lambda (invoke)
+		  (funcall invoke val)
+		  (emit-inst codegen (make-set-inst acc val)))
+  :methods (lambda (invoke)
+	     (funcall invoke val)
+	     (emit-inst codegen (make-update-inst acc #\+ val))))
+
+(define-aggregating-method-combination :product ((acc val) :codegen codegen)
+  :first-method (lambda (invoke)
+		  (funcall invoke val)
+		  (emit-inst codegen (make-set-inst acc val)))
+  :methods (lambda (invoke)
+	     (funcall invoke val)
+	     (emit-inst codegen (make-update-inst acc #\* val))))
+
+(define-aggregating-method-combination :min ((acc val) :codegen codegen)
+  :first-method (lambda (invoke)
+		  (funcall invoke val)
+		  (emit-inst codegen (make-set-inst acc val)))
+  :methods (lambda (invoke)
+	     (funcall invoke val)
+	     (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
+					      (make-set-inst acc val) nil))))
+
+(define-aggregating-method-combination :max ((acc val) :codegen codegen)
+  :first-method (lambda (invoke)
+		  (funcall invoke val)
+		  (emit-inst codegen (make-set-inst acc val)))
+  :methods (lambda (invoke)
+	     (funcall invoke val)
+	     (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
+					      (make-set-inst acc val) nil))))
+
+(define-aggregating-method-combination :and ((ret val) :codegen codegen)
+  :around (lambda (body)
+	    (codegen-push codegen)
+	    (deliver-expr codegen ret 0)
+	    (funcall body)
+	    (deliver-expr codegen ret 1)
+	    (emit-inst codegen
+		       (make-do-while-inst (codegen-pop-block codegen) 0)))
+  :methods (lambda (invoke)
+	     (funcall invoke val)
+	     (emit-inst codegen (make-if-inst (format nil "!~A" val)
+					      (make-break-inst) nil))))
+
+(define-aggregating-method-combination :or ((ret val) :codegen codegen)
+  :around (lambda (body)
+	    (codegen-push codegen)
+	    (deliver-expr codegen ret 1)
+	    (funcall body)
+	    (deliver-expr codegen ret 0)
+	    (emit-inst codegen
+		       (make-do-while-inst (codegen-pop-block codegen) 0)))
+  :methods (lambda (invoke)
+	     (funcall invoke val)
+	     (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
+
+(defmethod aggregating-message-properties
+    ((message aggregating-message) (combination (eql :custom)))
+  '(:retvar :id
+    :valvar :id
+    :decls :fragment
+    :before :fragment
+    :first :fragment
+    :each :fragment
+    :after :fragment))
+
+(defmethod compute-aggregating-message-kernel
+    ((message aggregating-message) (combination (eql :custom))
+     codegen target methods arg-names
+     &key (retvar "sod_ret") (valvar "sod_val")
+	  decls before each (first each) after)
+  (let* ((type (c-type-subtype (sod-message-type message)))
+	 (not-void-p (not (eq type c-type-void))))
+    (when not-void-p
+      (ensure-var codegen retvar type)
+      (ensure-var codegen valvar type))
+    (when decls
+      (emit-decl codegen decls))
+    (labels ((maybe-emit (fragment)
+	       (when fragment (emit-inst codegen fragment)))
+	     (invoke (method fragment)
+	       (invoke-method codegen (if not-void-p valvar :void)
+			      arg-names method)
+	       (maybe-emit fragment)))
+      (maybe-emit before)
+      (invoke (car methods) first)
+      (dolist (method (cdr methods)) (invoke method each))
+      (maybe-emit after)
+      (deliver-expr codegen target retvar))))
+
+(export 'standard-effective-method)
+(defclass aggregating-effective-method (simple-effective-method) ()
+  (:documentation "Effective method counterpart to `aggregating-message'."))
+
+(defmethod message-effective-method-class ((message aggregating-message))
+  'aggregating-effective-method)
+
+(defmethod simple-method-body
+    ((method aggregating-effective-method) codegen target)
+  (let ((argument-names (effective-method-basic-argument-names method))
+	(primary-methods (effective-method-primary-methods method)))
+    (funcall (message-kernel-function (effective-method-message method))
+	     codegen target argument-names primary-methods)))
+
 ;;;----- That's all, folks --------------------------------------------------