From 5e9b643f57d807c8c069ce8167115f170902cde9 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 24 Apr 2012 23:23:05 +0200 Subject: [PATCH] ECL's discriminating function protocol now relies on COMPUTE-APPLICABLE-METHODS-USING-CLASSES --- src/CHANGELOG | 5 +++ src/c/eval.d | 1 + src/c/gfun.d | 96 ++++++++++++++++++++++++++++++++++++--------- src/c/interpreter.d | 1 + src/clos/kernel.lsp | 59 ++++++++++++++++------------ src/h/object.h | 7 ++-- 6 files changed, 121 insertions(+), 48 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 4b653e625..ee88d13fb 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -66,6 +66,11 @@ ECL 12.2.2: - Implemented COMPUTE-DISCRIMINATING-FUNCTION. + - ECL's discriminating functions use COMPUTE-APPLICABLE-METHODS-USING-CLASSES + on those classes in which the user may redefine or extend the + method. Elsewhere, ECL relies on the internal equivalent of + COMPUTE-APPLICABLE-METHODS, which _always_ memoizes results. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/c/eval.d b/src/c/eval.d index 3e724ff2c..bfa136a8f 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -58,6 +58,7 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x) case t_instance: switch (fun->instance.isgf) { case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: return _ecl_standard_dispatch(frame, fun); case ECL_USER_DISPATCH: fun = fun->instance.slots[fun->instance.length - 1]; diff --git a/src/c/gfun.d b/src/c/gfun.d index a33b95738..7e4a2b3f4 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -81,6 +81,9 @@ clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t) if (function_or_t == Ct) { x->instance.isgf = ECL_STANDARD_DISPATCH; x->instance.entry = generic_function_dispatch_vararg; + } else if (function_or_t == @'standard-generic-function') { + x->instance.isgf = ECL_RESTRICTED_DISPATCH; + x->instance.entry = generic_function_dispatch_vararg; } else if (function_or_t == Cnil) { x->instance.isgf = ECL_NOT_FUNCALLABLE; x->instance.entry = FEnot_funcallable_vararg; @@ -137,24 +140,77 @@ fill_spec_vector(cl_object vector, cl_object frame, cl_object gf) } static cl_object -compute_applicable_method(cl_object frame, cl_object gf) +frame_to_list(cl_object frame) { - /* method not cached */ - cl_object methods, arglist, func; - cl_object *p; + cl_object arglist, *p; for (p = frame->frame.base + frame->frame.size, arglist = Cnil; p != frame->frame.base; ) { arglist = CONS(*(--p), arglist); } - methods = _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist); - if (methods == Cnil) { - func = _ecl_funcall3(@'no-applicable-method', gf, arglist); - frame->frame.base[0] = OBJNULL; - return func; - } else { - return _ecl_funcall4(@'clos::std-compute-effective-method', gf, - GFUN_COMB(gf), methods); + return arglist; +} + +static cl_object +frame_to_classes(cl_object frame) +{ + cl_object arglist, *p; + for (p = frame->frame.base + frame->frame.size, arglist = Cnil; + p != frame->frame.base; ) { + arglist = CONS(cl_class_of(*(--p)), arglist); } + return arglist; +} + +static cl_object +generic_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) +{ + /* method not cached */ + cl_object memoize; + cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes', + gf, frame_to_classes(frame)); + if (Null(memoize = env->values[1])) { + cl_object arglist = frame_to_list(frame); + methods = _ecl_funcall3(@'compute-applicable-methods', + gf, arglist); + if (methods == Cnil) { + cl_object func = _ecl_funcall3(@'no-applicable-method', + gf, arglist); + frame->frame.base[0] = OBJNULL; + env->values[1] = Cnil; + return func; + } + } + methods = _ecl_funcall4(@'clos::std-compute-effective-method', gf, + GFUN_COMB(gf), methods); + env->values[1] = Ct; + return methods; +} + +static cl_object +restricted_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) +{ + /* method not cached */ + cl_object arglist = frame_to_list(frame); + cl_object methods = _ecl_funcall3(@'clos::std-compute-applicable-methods', gf, arglist); + if (methods == Cnil) { + cl_object func = _ecl_funcall3(@'no-applicable-method', gf, arglist); + frame->frame.base[0] = OBJNULL; + env->values[1] = Cnil; + return func; + } + methods = _ecl_funcall4(@'clos::std-compute-effective-method', gf, + GFUN_COMB(gf), methods); + env->values[1] = Ct; + return methods; +} + +static cl_object +compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf) +{ + if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH) + return restricted_compute_applicable_method(env, frame, gf); + else + return generic_compute_applicable_method(env, frame, gf); } cl_object @@ -179,7 +235,7 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf) vector = fill_spec_vector(cache->keys, frame, gf); if (vector == OBJNULL) { - func = compute_applicable_method(frame, gf); + func = compute_applicable_method(env, frame, gf); } else { ecl_cache_record_ptr e = ecl_search_cache(cache); if (e->key != OBJNULL) { @@ -189,13 +245,15 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf) * compute the applicable methods. We must save * the keys and recompute the cache location if * it was filled. */ - cl_object keys = cl_copy_seq(vector); - func = compute_applicable_method(frame, gf); - if (e->key != OBJNULL) { - e = ecl_search_cache(cache); + 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; } - e->key = keys; - e->value = func; } } func = _ecl_funcall3(func, frame, Cnil); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 85f4deaee..43bdb2a2b 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -504,6 +504,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes) case t_instance: switch (reg0->instance.isgf) { case ECL_STANDARD_DISPATCH: + case ECL_RESTRICTED_DISPATCH: reg0 = _ecl_standard_dispatch(frame, reg0); break; case ECL_USER_DISPATCH: diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index cfc2087a9..6e0636bcf 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -226,8 +226,6 @@ ((typep x 'specializer) x) ((find-class x nil)) (t - (print name) - (print specializers) (error "In method definition for ~A, found an invalid specializer ~A" name specializers)))) specializers)) (method (make-method (generic-function-method-class gf) @@ -268,6 +266,14 @@ (setf (fdefinition name) gfun) gfun))) +(defun default-dispatch (generic-function) + (cond ((null *clos-booted*) + 'standard-generic-function) + ((eq (class-id (class-of generic-function)) + 'standard-generic-function) + 'standard-generic-function) + (t))) + (defun compute-discriminating-function (generic-function) (values #'(lambda (&rest args) (multiple-value-bind (method-list ok) @@ -288,30 +294,31 @@ t)) (defun set-generic-function-dispatch (gfun) - (let ((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 t))) - 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 t)) - finally (cond ((null class) - (return-from gf-type t)) - ((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 t)))))) + (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) (compute-discriminating-function gfun) diff --git a/src/h/object.h b/src/h/object.h index 998474a31..a2e5cc928 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -977,9 +977,10 @@ struct ecl_condition_variable { #define ECL_INSTANCEP(x) ((IMMEDIATE(x)==0) && ((x)->d.t==t_instance)) #define ECL_NOT_FUNCALLABLE 0 #define ECL_STANDARD_DISPATCH 1 -#define ECL_READER_DISPATCH 2 -#define ECL_WRITER_DISPATCH 3 -#define ECL_USER_DISPATCH 4 +#define ECL_RESTRICTED_DISPATCH 2 +#define ECL_READER_DISPATCH 3 +#define ECL_WRITER_DISPATCH 4 +#define ECL_USER_DISPATCH 5 struct ecl_instance { /* instance header */ HEADER1(isgf);