From d8547c5531b23656fc7a4de4a7d3c83c034ff32d Mon Sep 17 00:00:00 2001 From: Juanjo Garcia-Ripoll Date: Fri, 27 Apr 2012 16:09:17 +0200 Subject: [PATCH] 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 | 2 +- src/c/gfun.d | 41 ++++++++++----------- src/clos/boot.lsp | 7 +++- src/clos/combin.lsp | 22 ++++++++---- src/clos/kernel.lsp | 88 +++++++++++++++++++++++++++------------------ 5 files changed, 95 insertions(+), 65 deletions(-) diff --git a/src/c/eval.d b/src/c/eval.d index 8348a26b3..c23d5f2a3 100644 --- a/src/c/eval.d +++ b/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); diff --git a/src/c/gfun.d b/src/c/gfun.d index e8fbef203..c4f0dbb4e 100644 --- a/src/c/gfun.d +++ b/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); diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index f6b88fd1f..8e9273e3a 100644 --- a/src/clos/boot.lsp +++ b/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)) diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index 62fe1074b..bd0809158 100644 --- a/src/clos/combin.lsp +++ b/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))))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 635644f4e..337b19035 100644 --- a/src/clos/kernel.lsp +++ b/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