X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/3109662aca9c06495ac22c5c58b46e1c036aca5c..2aa518549b302b3556dbaa42585e6fc16a63ae7c:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index b74994f..e1b4980 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -46,6 +46,7 @@ (defclass basic-message (sod-message)
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'argument-tail)))
+  (declare (ignore class))
   (let ((seq 0))
     (setf (slot-value message 'argument-tail)
 	  (mapcar (lambda (arg)
@@ -59,6 +60,7 @@ (defmethod slot-unbound (class
 (defmethod slot-unbound (class
 			 (message basic-message)
 			 (slot-name (eql 'no-varargs-tail)))
+  (declare (ignore class))
   (setf (slot-value message 'no-varargs-tail)
 	(mapcar (lambda (arg)
 		  (if (eq arg :ellipsis)
@@ -96,6 +98,9 @@ (defmethod sod-message-method-class
       (call-next-method)
       (primary-method-class message)))
 
+(defmethod primary-method-class ((message simple-message))
+  'basic-direct-method)
+
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 
@@ -125,6 +130,7 @@   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 
 (defmethod slot-unbound
     (class (method basic-direct-method) (slot-name (eql 'function-type)))
+  (declare (ignore class))
   (let ((type (sod-method-type method)))
     (setf (slot-value method 'function-type)
 	  (c-type (fun (lisp (c-type-subtype type))
@@ -184,16 +190,19 @@ (defclass delegating-direct-method (basic-direct-method)
 (defmethod slot-unbound (class
 			 (method delegating-direct-method)
 			 (slot-name (eql 'next-method-type)))
+  (declare (ignore class))
   (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))))))
+		       .
+		       (c-function-arguments type))))))
 
 (defmethod slot-unbound (class
 			 (method delegating-direct-method)
 			 (slot-name (eql 'function-type)))
+  (declare (ignore class))
   (let* ((message (sod-method-message method))
 	 (type (sod-method-type method))
 	 (method-args (c-function-arguments type)))
@@ -238,6 +247,7 @@ (defclass basic-effective-method (effective-method)
 (defmethod slot-unbound (class
 			 (method basic-effective-method)
 			 (slot-name (eql 'basic-argument-names)))
+  (declare (ignore class))
   (let ((message (effective-method-message method)))
     (setf (slot-value method 'basic-argument-names)
 	  (subst *sod-master-ap* *sod-ap*
@@ -255,6 +265,7 @@ (defmethod effective-method-function-name ((method effective-method))
 
 (defmethod slot-unbound
     (class (method basic-effective-method) (slot-name (eql 'functions)))
+  (declare (ignore class))
   (setf (slot-value method 'functions)
 	(compute-method-entry-functions method)))
 
@@ -285,6 +296,7 @@ (defmethod shared-initialize :after
 
 (defmethod shared-initialize :after
     ((codegen method-codegen) slot-names &key)
+  (declare (ignore slot-names))
   (with-slots (message target) codegen
     (setf target
 	  (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
@@ -311,19 +323,18 @@ (defun basic-effective-method-body (codegen target method body)
       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))
+	       (if (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)))))))
+						     basic-tail after)))))))
 	(invoke-delegation-chain codegen target basic-tail
 				 around-methods #'method-kernel)))))
 
@@ -413,9 +424,6 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 	 (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)
@@ -453,48 +461,55 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
 
       ;; 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)))))
+      (let* ((result (if (eq return-type c-type-void) nil
+			 (temporary-var codegen return-type)))
+	     (emf-target (or result :void)))
+	(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)
-		   (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))))))
+		   (dolist (var vars)
+		     (if (typep var 'var-inst)
+			 (ensure-var codegen (inst-name var)
+				     (inst-type var) (inst-init var))
+			 (emit-decl codegen 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))))
 
@@ -506,12 +521,11 @@ (defmethod compute-method-entry-functions
 
 (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)))))
+  (basic-effective-method-body codegen target method
+			       (lambda (target)
+				 (simple-method-body method
+						     codegen
+						     target))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Standard method combination.
@@ -520,7 +534,7 @@ (export 'standard-message)
 (defclass standard-message (simple-message)
   ()
   (:documentation
-   "Message class for standard method combination.
+   "Message class for standard method combinations.
 
    Standard method combination is a simple method combination where the
    primary methods are invoked as a delegation chain, from most- to
@@ -544,4 +558,401 @@ (defmethod simple-method-body
 			   (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 --------------------------------------------------