Precompile all effective methods required by standard method combinations.

src/clos/combin.lsp

@@ -26,18 +26,6 @@
 ;;; it should be enough with a couple of different closures and hence
 ;;; the structural comparison is a loss of time.
 
-;;;
-;;; This function produces an effective method associated to the form
-;;;	(CALL-METHOD-FUNCTION method rest-methods)
-;;;
-(defun combine-method-functions (method rest-methods)
-  (declare (si::c-local))
-  (setf method (effective-method-function method)
-	rest-methods (mapcar #'effective-method-function rest-methods))
-  #'(lambda (&rest .combined-method-args.)
-      (let ((*next-methods* rest-methods))
-	(apply method .combined-method-args.))))
-
 ;;;
 ;;; This is the core routine. It produces effective methods (i.e.
 ;;; functions) out of the forms generated by the method combinators.
@@ -54,6 +42,8 @@
 ;;;	the forms in a null environment. This is the only form
 ;;;	that may lead to consing of new bytecodes objects. Nested
 ;;;	CALL-METHOD are handled via the global macro CALL-METHOD.
+;;;  5) Ordinary forms are turned into lambda forms, much like
+;;;	what happens with the content of MAKE-METHOD.
 ;;;
 (defun effective-method-function (form)
   (if (atom form)
@@ -65,7 +55,9 @@
 	     (error "Malformed effective method form:~%~A" form)))
       (case (first form)
 	(CALL-METHOD
-	 (combine-method-functions (second form) (third form)))
+	 (combine-method-functions
+	  (effective-method-function (second form))
+	  (mapcar #'effective-method-function (third form))))
 	(MAKE-METHOD
 	 (setq form (second form))
 	 (coerce `(lambda (&rest .combined-method-args.) ,form)
@@ -74,15 +66,24 @@
 	 (coerce `(lambda (&rest .combined-method-args.) ,form)
 		 'function)))))
 
+;;;
+;;; This function is a combinator of effective methods. It creates a
+;;; closure that invokes the first method while passing the information
+;;; of the remaining methods. The resulting closure (or effective method)
+;;; is the equivalent of (CALL-METHOD method rest-methods)
+;;;
+(defun combine-method-functions (method rest-methods)
+  (declare (si::c-local))
+  #'(lambda (&rest .combined-method-args.)
+      (let ((*next-methods* rest-methods))
+	(apply method .combined-method-args.))))
+
 (defmacro call-method (method rest-methods)
   (setq method (effective-method-function method)
 	rest-methods (mapcar #'effective-method-function rest-methods))
   `(let ((*next-methods* ,rest-methods))
      (apply ,method .combined-method-args.)))
 
-(defun make-method-call (method &optional next-methods)
-  `(CALL-METHOD ,method ,next-methods))
-
 (defun error-qualifier (m qualifier)
   (declare (si::c-local))
   (error "Standard method combination allows only one qualifier ~
@@ -90,38 +91,37 @@
           a method with ~S was found."
 	 m qualifier))
 
-#+nil
 (defun standard-main-effective-method (before primary after)
-  (setf before (mapcar #'effective-method-function before)
-	after (mapcar #'effective-method-function after)
-	primary (mapcar #'effective-method-function primary))
+  (declare (si::c-local))
   #'(lambda (&rest .combined-method-args.)
       (let ((*next-methods* nil))
 	(declare (special *next-methods*))
 	(dolist (i before)
 	  (apply i .combined-method-args.))
-	(multiple-value-prog1
-	    (progn
-	      (setf *next-methods* (rest primary))
-	      (apply (first primary) .combined-method-args.))
-	  (setf *next-methods* nil)
-	  (dolist (i after)
-	    (apply i .combined-method-args.))))))
+	(setf *next-methods* (rest primary))
+	(if after
+	    (multiple-value-prog1
+		(apply (first primary) .combined-method-args.)
+	      (setf *next-methods* nil)
+	      (dolist (i after)
+		(apply i .combined-method-args.)))
+	    (apply (first primary) .combined-method-args.)))))
 
 (defun standard-compute-effective-method (gf methods)
-  (declare (ignore gf))
-  (let*((before ())
-	(primary ())
-	(after ())
-	(around ()))
+  (declare (si::c-local))
+  (let* ((before ())
+	 (primary ())
+	 (after ())
+	 (around ()))
     (dolist (m methods)
-      (let ((qualifiers (method-qualifiers m)))
-	(cond ((null qualifiers) (push m primary))
+      (let* ((qualifiers (method-qualifiers m))
+	     (f (method-function m)))
+	(cond ((null qualifiers) (push f primary))
 	      ((rest qualifiers) (error-qualifier m qualifiers))
 	      ((eq (setq qualifiers (first qualifiers)) :BEFORE)
-	       (push m before))
-	      ((eq qualifiers :AFTER) (push m after))
-	      ((eq qualifiers :AROUND) (push m around))
+	       (push f before))
+	      ((eq qualifiers :AFTER) (push f after))
+	      ((eq qualifiers :AROUND) (push f around))
 	      (t (error-qualifier m qualifiers)))))
     ;; When there are no primary methods, an error is to be signaled,
     ;; and we need not care about :AROUND, :AFTER or :BEFORE methods.
@@ -129,27 +129,23 @@
       (return-from standard-compute-effective-method
 	#'(lambda (&rest args)
 	    (apply 'no-primary-method gf args))))
-    (setq before (nreverse before) ;; most-specific-first order (ANSI 7.6.6.2)
-	  after after		   ;; least-specific-first order (ANSI 7.6.6.2)
-	  primary (nreverse primary)
-	  around (nreverse around))
-    (if (and (null before)
-	     (null after))
-	(if (null around)
-	    ;; By returning a single call-method `form' here we enable
-	    ;; an important implementation-specific optimization.
-	    (combine-method-functions (first primary) (rest primary))
-	    (combine-method-functions (first around)
-				      (append (rest around) primary)))
-	(let ((main (effective-method-function
-		     `(PROGN ,@(mapcar #'make-method-call before)
-			     (MULTIPLE-VALUE-PROG1
-				 (CALL-METHOD ,(first primary) ,(rest primary))
-			       ,@(mapcar #'make-method-call after))))))
-	  (if around
-	      (combine-method-functions (first around)
-					(append (rest around) main))
-	      main)))))
+    ;; PRIMARY, BEFORE and AROUND are reversed because they have to
+    ;; be on most-specific-first order (ANSI 7.6.6.2), while AFTER
+    ;; may remain as it is because it is least-specific-order.
+    (setf primary (nreverse primary)
+	  before (nreverse before))
+    (if around
+	(let ((main (if (or before after)
+			(list
+			 (standard-main-effective-method before primary after))
+			primary)))
+	  (setf around (nreverse around))
+	  (combine-method-functions (first around)
+				    (nconc (rest around) main)))
+	(if (or before after)
+	    (standard-main-effective-method before primary after)
+	    (combine-method-functions (first primary) (rest primary))))
+    ))
 
 ;; ----------------------------------------------------------------------
 ;; DEFINE-METHOD-COMBINATION