When computing the generic function dispatch, we eliminate the case in which the generic function takes too many required arguments. Slight optimizations in STD-COMPUTE-EFFECTIVE-METHOD.

src/c/eval.d

@@ -62,7 +62,7 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
 			return _ecl_standard_dispatch(frame, fun);
 		case ECL_USER_DISPATCH:
 			fun = fun->instance.slots[fun->instance.length - 1];
-			goto AGAIN;
+                        goto AGAIN;
 		case ECL_READER_DISPATCH:
 		case ECL_WRITER_DISPATCH:
 			return APPLY(narg, fun->instance.entry, sp);

src/c/gfun.d

@@ -125,15 +125,15 @@ fill_spec_vector(cl_object vector, cl_object frame, cl_object gf)
 		cl_object spec_how = ECL_CONS_CAR(spec_how_list);
 		cl_object spec_type = ECL_CONS_CAR(spec_how);
 		int spec_position = fix(ECL_CONS_CDR(spec_how));
-		if (spec_position >= narg)
+		unlikely_if (spec_position >= narg)
 			FEwrong_num_arguments(gf);
+		unlikely_if (spec_no >= vector->vector.dim)
+			ecl_internal_error("Too many arguments to fill_spec_vector()");
 		argtype[spec_no++] =
-			(ATOM(spec_type) ||
+			(!ECL_LISTP(spec_type) ||
 			 Null(ecl_memql(args[spec_position], spec_type))) ?
 			cl_class_of(args[spec_position]) :
 			args[spec_position];
-		if (spec_no > vector->vector.dim)
-			return OBJNULL;
 	} end_loop_for_on_unsafe(spec_how_list);
 	vector->vector.fillp = spec_no;
 	return vector;
@@ -217,6 +217,7 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
 	cl_object func, vector;
         const cl_env_ptr env = frame->frame.env;
 	ecl_cache_ptr cache = env->method_cache;
+	ecl_cache_record_ptr e;
 	/*
 	 * We have to copy the frame because it might be stored in cl_env.values
 	 * which will be wiped out by the next function call. However this only
@@ -232,26 +233,22 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
 #endif
 	
 	vector = fill_spec_vector(cache->keys, frame, gf);
-	if (vector == OBJNULL) {
-		func = compute_applicable_method(env, frame, gf);
+	e = ecl_search_cache(cache);
+	if (e->key != OBJNULL) {
+		func = e->value;
 	} else {
-		ecl_cache_record_ptr e = ecl_search_cache(cache);
-		if (e->key != OBJNULL) {
-			func = e->value;
-		} else {
-			/* The keys and the cache may change while we
-			 * compute the applicable methods. We must save
-			 * the keys and recompute the cache location if
-			 * it was filled. */
-			func = compute_applicable_method(env, frame, gf);
-			if (env->values[1] != Cnil) {
-				cl_object keys = cl_copy_seq(vector);
-				if (e->key != OBJNULL) {
-					e = ecl_search_cache(cache);
-				}
-				e->key = keys;
-				e->value = func;
+		/* The keys and the cache may change while we
+		 * compute the applicable methods. We must save
+		 * the keys and recompute the cache location if
+		 * it was filled. */
+		func = compute_applicable_method(env, frame, gf);
+		if (env->values[1] != Cnil) {
+			cl_object keys = cl_copy_seq(vector);
+			if (e->key != OBJNULL) {
+				e = ecl_search_cache(cache);
 			}
+			e->key = keys;
+			e->value = func;
 		}
 	}
 	func = _ecl_funcall3(func, frame, Cnil);

src/clos/boot.lsp

@@ -147,7 +147,12 @@
   ;;
   ;; 3) Finalize
   ;;
-  (mapc #'si::instance-sig-set all-classes))
+  (mapc #'si::instance-sig-set all-classes)
+  ;;
+  ;; This is needed for further optimization
+  ;;
+  (setf (class-sealedp (find-class 'method-combination)) t)
+  )
 
 (defconstant +the-t-class+ (find-class 't nil))
 (defconstant +the-class+ (find-class 'class nil))

src/clos/combin.lsp

@@ -12,7 +12,7 @@
 
 (in-package "CLOS")
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; COMPILING EFFECTIVE METHODS
 ;;;
 ;;; The following functions take care of transforming the forms
@@ -323,7 +323,17 @@
 ;;; COMPUTE-EFFECTIVE-METHOD
 ;;;
 
+(eval-when (compile)
+  (let* ((class (find-class 'method-combination)))
+    (define-compiler-macro method-combination-compiler (o)
+      `(si::instance-ref ,o ,(slot-definition-location (gethash 'compiler (slot-table class)))))
+    (define-compiler-macro method-combination-options (o)
+      `(si::instance-ref ,o ,(slot-definition-location (gethash 'options (slot-table class)))))))
+
 (defun std-compute-effective-method (gf method-combination applicable-methods)
+  (declare (type method-combination method-combination)
+	   (type generic-function gf)
+	   (optimize speed (safety 0)))
   (let* ((compiler (method-combination-compiler method-combination))
 	 (options (method-combination-options method-combination)))
     (if options
@@ -335,11 +345,11 @@
   (declare (notinline compute-effective-method))
   (let ((form (compute-effective-method gf method-combination applicable-methods)))
     (let ((aux form) f)
-      (if (and (listp form)
-		 (eq (pop form) 'funcall)
-		 (functionp (setf f (pop form)))
-		 (eq (second form) '.combined-method-args.)
-		 (eq (third form) '*next-methods*))
+      (if (and (listp aux)
+		 (eq (pop aux) 'funcall)
+		 (functionp (setf f (pop aux)))
+		 (eq (pop aux) '.combined-method-args.)
+		 (eq (pop aux) '*next-methods*))
 	  f
 	  (effective-method-function form t)))))
 

src/clos/kernel.lsp

@@ -273,7 +273,7 @@
 	(when l-l-p
 	  (setf (generic-function-argument-precedence-order gfun)
 		(rest (si::process-lambda-list lambda-list t))))
-	(set-funcallable-instance-function gfun t)
+	(set-funcallable-instance-function gfun 'standard-generic-function)
 	(setf (fdefinition name) gfun)
 	gfun)))
 
@@ -296,7 +296,7 @@
 			(compute-applicable-methods generic-function args))
 		  (unless method-list
 		    (no-applicable-methods generic-function args)))
-		(funcall (compute-effective-method
+		(funcall (compute-effective-method-function
 			  generic-function
 			  (generic-function-method-combination generic-function)
 			  method-list)
@@ -305,39 +305,57 @@
 	  t))
 
 (defun set-generic-function-dispatch (gfun)
-  (let* ((base (default-dispatch gfun))
-	 (gf-type
-	  (loop named gf-type
-	     with common-class = nil
-	     for method in (generic-function-methods gfun)
-	     for class = (si::instance-class method)
-	     for specializers = (method-specializers method)
-	     do (cond ((null common-class)
-		       (setf common-class class))
-		      ((not (eq common-class class))
-		       (return-from gf-type base)))
-	     do (loop for spec in specializers
-		   unless (or (eq spec +the-t-class+)
-			      (and (si::instancep spec)
-				   (eq (si::instance-class spec)
-				       +the-standard-class+)))
-		   do (return-from gf-type base))
-	     finally (cond ((null class)
-			    (return-from gf-type base))
-			   ((eq class (find-class 'standard-reader-method nil))
-			    (return-from gf-type 'standard-reader-method))
-			   ((eq class (find-class 'standard-writer-method nil))
-			    (return-from gf-type 'standard-writer-method))
-			   (t
-			    (return-from gf-type base))))))
-    (when (and *clos-booted* (eq gf-type t))
-      (multiple-value-bind (function optimize)
-	  (locally (declare (notinline compute-discriminating-function))
-	    (compute-discriminating-function gfun))
-	(unless optimize
-	  (setf gf-type function))))
-    (set-funcallable-instance-function gfun gf-type)))
-
+  ;;
+  ;; We have to decide which discriminating function to install:
+  ;;	1* One supplied by the user
+  ;;	2* One coded in C that follows the MOP
+  ;;	3* One in C specialized for slot accessors
+  ;;	4* One in C that does not use generic versions of compute-applicable-...
+  ;; Respectively
+  ;;	1* The user supplies a discriminating function, or the number of arguments
+  ;;	   is so large that they cannot be handled by the C dispatchers with
+  ;;	   with memoization.
+  ;;	2* The generic function is not a s-g-f but takes less than 64 arguments
+  ;;	3* The generic function is a standard-generic-function and all its slots
+  ;;	   are standard-{reader,writer}-slots
+  ;;	4* The generic function is a standard-generic-function with less
+  ;;	   than 64 arguments
+  ;;
+  ;; This chain of reasoning uses the fact that the user cannot override methods
+  ;; such as COMPUTE-APPLICABLE-METHODS, or COMPUTE-EFFECTIVE-METHOD, or
+  ;; COMPUTE-DISCRIMINATING-FUNCTION acting on STANDARD-GENERIC-FUNCTION.
+  ;;
+  (multiple-value-bind (default-function optimizable)
+      ;;
+      ;; If the class is not a standard-generic-function, we must honor whatever function
+      ;; the user provides. However, we still recognize the case without user-computed
+      ;; function, where we can replace the output of COMPUTE-DISCRIMINATING-FUNCTION with
+      ;; a similar implementation in C
+      (compute-discriminating-function gfun)
+    (set-funcallable-instance-function
+     gfun
+     (cond
+       ;; Case 1*
+       ((or (not optimizable)
+	    (> (length (generic-function-spec-list gfun))
+	       si::c-arguments-limit))
+	default-function)
+       ;; Case 2*
+       ((and (not (eq (class-id (class-of gfun)) 'standard-generic-function))
+	     *clos-booted*)
+	t)
+       ;; Cases 3*
+       ((loop with class = (find-class 'standard-reader-method nil)
+	   for m in (generic-function-methods gfun)
+	   always (eq class (class-of m)))
+	'standard-reader-method)
+       ((loop with class = (find-class 'standard-writer-method nil)
+	   for m in (generic-function-methods gfun)
+	   always (eq class (class-of m)))
+	'standard-writer-method)
+       ;; Case 4*
+       (t
+	'standard-generic-function)))))
 
 ;;; ----------------------------------------------------------------------
 ;;; COMPUTE-APPLICABLE-METHODS