The method combination slot in a generic function is now precomputed using FIND-METHOD-COMBINATION.

src/CHANGELOG

@@ -74,6 +74,9 @@ ECL 12.2.2:
  - When reinitializing a class instance, ECL would not remove the class from
    its former superclasses.
 
+ - The method combination slot of a generic function is now precomputed by
+   using FIND-METHOD-COMBINATION in SHARED-INITIALIZE.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/clos/combin.lsp

@@ -128,7 +128,6 @@
 	(funcall (first primary) .combined-method-args. (rest primary)))))
 
 (defun standard-compute-effective-method (gf methods)
-  (declare (si::c-local))
   (let* ((before ())
 	 (primary ())
 	 (after ())
@@ -185,12 +184,32 @@
 ;; and it outputs an anonymous function which is the effective method.
 ;;
 
-(defparameter *method-combinations* '())
+#+threads
+(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination))
+(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq))
+
+(defun search-method-combination (name)
+  (mp:with-lock (*method-combinations-lock*)
+    (or (gethash name *method-combinations*)
+	(error "~A does not name a method combination" name))))
 
 (defun install-method-combination (name function)
-  (setf (getf *method-combinations* name) function)
+  (mp:with-lock (*method-combinations-lock*)
+    (setf (gethash name *method-combinations*) function))
   name)
 
+(defun method-combination-object-p (o)
+  (and (listp o)
+       (= (length o) 3)
+       (eq (first o)
+	   (mp:with-lock (*method-combinations-lock*)
+	     (gethash (third o) *method-combinations*)))))
+
+(defun find-method-combination (gf method-combination-type-name method-combination-options)
+  (list (search-method-combination method-combination-type-name)
+	method-combination-options
+	method-combination-type-name))
+
 (defun define-simple-method-combination (name &key documentation
 					 identity-with-one-argument
 					 (operator name))
@@ -302,19 +321,19 @@
 ;;;
 
 (defun std-compute-effective-method (gf method-combination applicable-methods)
-  (let* ((method-combination-name (car method-combination))
-	 (method-combination-args (cdr method-combination)))
-    (if (eq method-combination-name 'STANDARD)
-	(standard-compute-effective-method gf applicable-methods)
-	(apply (or (getf *method-combinations* method-combination-name)
-		   (error "~S is not a valid method combination object"
-			  method-combination))
+  (let* ((method-combination-function (first method-combination))
+	 (method-combination-args (second method-combination)))
+    (if method-combination-args
+	(apply method-combination-function
 	       gf applicable-methods
-	       method-combination-args))))
+	       method-combination-args)
+	(funcall method-combination-function
+		 gf applicable-methods))))
 
 ;;
 ;; These method combinations are bytecompiled, for simplicity.
 ;;
+(install-method-combination 'standard 'standard-compute-effective-method)
 (eval '(progn
 	(define-method-combination progn :identity-with-one-argument t)
 	(define-method-combination and :identity-with-one-argument t)

src/clos/generic.lsp

@@ -120,7 +120,6 @@
 			      (argument-precedence-order nil a-o-p)
 			      (documentation nil)
 			      (declarations nil)
-			      method-combination
 			      (method-class (find-class 'method))
 			      )
   (declare (ignore initargs slot-names))
@@ -142,14 +141,6 @@
 	   :format-arguments (list documentation)
 	   :datum documentation
 	   :expected-type '(or null string)))
-  (unless (or (null method-combination)
-	      (and (listp method-combination)
-		   (member (first method-combination) *method-combinations*)))
-    (error 'simple-type-error
-	   :format-control "Not a valid method combination, ~A"
-	   :format-arguments (list method-combination)
-	   :datum method-combination
-	   :expected-type 'list))
   (unless (si::subclassp method-class (find-class 'method))
     (error 'simple-type-error
 	   :format-control "Not a valid method class, ~A"
@@ -167,6 +158,10 @@
       (simple-program-error "Cannot replace the lambda list of ~A with ~A because it is incongruent with some of the methods"
 			    gfun lambda-list)))
   (call-next-method)
+  (let ((combination (generic-function-method-combination gfun)))
+    (unless (method-combination-object-p combination)
+      (setf (generic-function-method-combination gfun)
+	    (find-method-combination gfun (first combination) (rest combination)))))
   (when (and l-l-p (not a-o-p))
     (setf (generic-function-argument-precedence-order gfun)
 	  (lambda-list-required-arguments lambda-list)))

src/clos/kernel.lsp

@@ -126,7 +126,7 @@
        :accessor generic-function-name)
       (spec-list :initform nil :accessor generic-function-spec-list)
       (method-combination 
-       :initarg :method-combination :initform '(standard)
+       :initarg :method-combination :initform '(standard-compute-effective-method nil standard)
        :accessor generic-function-method-combination)
       (lambda-list :initarg :lambda-list
        :accessor generic-function-lambda-list)
@@ -253,7 +253,8 @@
 	(si::instance-sig-set gfun)
 	(setf (generic-function-name gfun) name
 	      (generic-function-lambda-list gfun) lambda-list
-	      (generic-function-method-combination gfun) '(standard)
+	      (generic-function-method-combination gfun)
+	      (find-method-combination gfun 'standard nil)
 	      (generic-function-methods gfun) nil
 	      (generic-function-spec-list gfun) nil
               (generic-function-dependents gfun) nil)