summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-20 13:31:07 +0100
committerAndy Wingo <wingo@pobox.com>2009-11-26 00:25:07 +0100
commit9022ff183c44976b7f28503f9f78c523b578846a (patch)
tree2fd53c6909ec5dd91eafd48013a2e1ce4a06a7c8
parent5bdea5bd3de9a592e91c194d73bfd0681894a2ca (diff)
downloadguile-9022ff183c44976b7f28503f9f78c523b578846a.tar.gz
remove code that manages the method cache
* libguile/goops.h (SCM_MCACHE_N_SPECIALIZED) (SCM_SET_MCACHE_N_SPECIALIZED, SCM_INITIAL_MCACHE_SIZE) (scm_make_method_cache, scm_memoize_method, scm_mcache_lookup_cmethod) (scm_mcache_compute_cmethod): * libguile/goops.c: Remove these procedures which managed the method cache. There's still a slot there but it's not initialized. The method cache is no longer necessary. * module/oop/goops/dispatch.scm (memoize-method!): Change to not take a "cache" argument. * libguile/eval.i.c: * libguile/vm-i-system.c: Remove dispatch via the method cache.
-rw-r--r--libguile/eval.i.c53
-rw-r--r--libguile/goops.c135
-rw-r--r--libguile/goops.h8
-rw-r--r--libguile/vm-i-system.c33
-rw-r--r--module/oop/goops/dispatch.scm4
5 files changed, 2 insertions, 231 deletions
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index d78f498d7..681169878 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -733,23 +733,6 @@ dispatch:
case (ISYMNUM (SCM_IM_DELAY)):
RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
- /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
- code (type_dispatch) is intended to be the tail of the case
- clause for the internal macro SCM_IM_DISPATCH. Please don't
- remove it from this location without discussing it with Mikael
- <djurfeldt@nada.kth.se> */
-
- /* The type dispatch code is duplicated below
- * (c.f. objects.c:scm_mcache_compute_cmethod) since that
- * cuts down execution time for type dispatch to 50%. */
- type_dispatch: /* inputs: x, arg1 */
- {
- proc = scm_mcache_compute_cmethod (x, arg1);
- PREP_APPLY (proc, arg1);
- goto apply_proc;
- }
-
-
case (ISYMNUM (SCM_IM_SLOT_REF)):
x = SCM_CDR (x);
{
@@ -1034,12 +1017,6 @@ dispatch:
#endif
goto evap0;
}
- else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
- arg1 = SCM_EOL;
- goto type_dispatch;
- }
else
goto badfun;
case scm_tc7_subr_1:
@@ -1159,16 +1136,6 @@ dispatch:
#endif
goto evap1;
}
- else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_1 (arg1);
-#endif
- goto type_dispatch;
- }
else
goto badfun;
case scm_tc7_subr_2:
@@ -1244,16 +1211,6 @@ dispatch:
SCM_EOL));
#endif
}
- else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
- x = SCM_GENERIC_METHOD_CACHE (proc);
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_list_2 (arg1, arg2);
-#endif
- goto type_dispatch;
- }
else
goto badfun;
case scm_tc7_subr_0:
@@ -1455,16 +1412,6 @@ dispatch:
case scm_tcs_struct:
if (SCM_STRUCT_APPLICABLE_P (proc))
goto operatorn;
- else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- {
-#ifdef DEVAL
- arg1 = debug.info->a.args;
-#else
- arg1 = scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc));
-#endif
- x = SCM_GENERIC_METHOD_CACHE (proc);
- goto type_dispatch;
- }
else
goto badfun;
case scm_tc7_subr_2:
diff --git a/libguile/goops.c b/libguile/goops.c
index 4a38f397c..aee8ee280 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -78,7 +78,6 @@ static SCM var_slot_unbound = SCM_BOOL_F;
static SCM var_slot_missing = SCM_BOOL_F;
static SCM var_compute_cpl = SCM_BOOL_F;
static SCM var_no_applicable_method = SCM_BOOL_F;
-static SCM var_memoize_method_x = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
@@ -1692,111 +1691,6 @@ static SCM list_of_no_method;
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
-/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
- * formats:
- *
- * Format #1:
- * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
- * #((TYPE1 ... . CMETHOD) ...)
- * GF)
- *
- * Format #2:
- * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
- * #((TYPE1 ... CMETHOD) ...)
- * GF)
- *
- * ARGS is either a list of expressions, in which case they
- * are interpreted as the arguments of an application, or
- * a non-pair, which is interpreted as a single expression
- * yielding all arguments.
- *
- * SCM_IM_DISPATCH expressions in generic functions always
- * have ARGS = the symbol `args' or the iloc #@0-0.
- *
- * We should probably not complicate this mechanism by
- * introducing "optimizations" for getters and setters or
- * primitive methods. Getters and setter will normally be
- * compiled into @slot-[ref|set!] or a procedure call.
- * They rely on the dispatch performed before executing
- * the code which contains them.
- *
- * We might want to use a more efficient representation of
- * this form in the future, perhaps after we have introduced
- * low-level support for syntax-case macros.
- */
-
-SCM
-scm_mcache_lookup_cmethod (SCM cache, SCM args)
-{
- unsigned long i, mask, n, end;
- SCM ls, methods, z = SCM_CDDR (cache);
- n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
- methods = SCM_CADR (z);
-
- if (scm_is_simple_vector (methods))
- {
- /* cache format #1: prepare for linear search */
- mask = -1;
- i = 0;
- end = SCM_SIMPLE_VECTOR_LENGTH (methods);
- }
- else
- {
- /* cache format #2: compute a hash value */
- unsigned long hashset = scm_to_ulong (methods);
- long j = n;
- z = SCM_CDDR (z);
- mask = scm_to_ulong (SCM_CAR (z));
- methods = SCM_CADR (z);
- i = 0;
- ls = args;
- if (!scm_is_null (ls))
- do
- {
- i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
- [scm_si_hashsets + hashset];
- ls = SCM_CDR (ls);
- }
- while (j-- && !scm_is_null (ls));
- i &= mask;
- end = i;
- }
-
- /* Search for match */
- do
- {
- long j = n;
- z = SCM_SIMPLE_VECTOR_REF (methods, i);
- ls = args; /* list of arguments */
- /* More arguments than specifiers => z = CMETHOD, not a pair.
- * Fewer arguments than specifiers => CAR != CLASS or `no-method'. */
- if (!scm_is_null (ls) && scm_is_pair (z))
- do
- {
- if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
- goto next_method;
- ls = SCM_CDR (ls);
- z = SCM_CDR (z);
- }
- while (j-- && !scm_is_null (ls) && scm_is_pair (z));
- if (!scm_is_pair (z))
- return z;
- next_method:
- i = (i + 1) & mask;
- } while (i != end);
- return SCM_BOOL_F;
-}
-
-SCM
-scm_mcache_compute_cmethod (SCM cache, SCM args)
-{
- SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
- if (scm_is_false (cmethod))
- /* No match - memoize */
- return scm_memoize_method (cache, args);
- return cmethod;
-}
-
SCM
scm_apply_generic (SCM gf, SCM args)
{
@@ -1827,17 +1721,6 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
}
-SCM
-scm_make_method_cache (SCM gf)
-{
- return scm_list_5 (SCM_IM_DISPATCH,
- scm_sym_args,
- scm_from_int (1),
- scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
- list_of_no_method),
- gf);
-}
-
SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
static SCM
make_dispatch_procedure (SCM gf)
@@ -1852,8 +1735,6 @@ make_dispatch_procedure (SCM gf)
static void
clear_method_cache (SCM gf)
{
- SCM cache = scm_make_method_cache (gf);
- SCM_SET_GENERIC_METHOD_CACHE (gf, cache);
SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf, make_dispatch_procedure (gf));
SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf);
}
@@ -1865,9 +1746,6 @@ SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0
{
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
clear_method_cache (gf);
- /* The sign of n-specialized is a flag indicating rest args. */
- SCM_SET_MCACHE_N_SPECIALIZED (SCM_GENERIC_METHOD_CACHE (gf),
- SCM_SLOT (gf, scm_si_n_specialized));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -2224,19 +2102,6 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args)
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
-SCM
-scm_memoize_method (SCM cache, SCM args)
-{
- SCM gf = SCM_CAR (scm_last_pair (cache));
-
- if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
- var_memoize_method_x =
- scm_permanent_object
- (scm_module_variable (scm_module_goops, sym_memoize_method_x));
-
- return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, args, cache);
-}
-
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
diff --git a/libguile/goops.h b/libguile/goops.h
index 57604a035..312304025 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -154,8 +154,6 @@ typedef struct scm_t_method {
#define SCM_GENERIC_METHOD_CACHE(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_si_generic_cache]))
#define SCM_SET_GENERIC_METHOD_CACHE(G,C) (SCM_STRUCT_DATA (G) [scm_si_generic_cache] = SCM_UNPACK (C))
-#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
-#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)
#define SCM_SET_GENERIC_DISPATCH_PROCEDURE(G,C) (SCM_STRUCT_SLOT_SET (G, scm_si_dispatch_procedure, (C)))
#define SCM_CLEAR_GENERIC_EFFECTIVE_METHODS(G) (SCM_STRUCT_SLOT_SET (G, scm_si_effective_methods, SCM_EOL));
@@ -163,8 +161,6 @@ typedef struct scm_t_method {
#define SCM_GENERIC_SETTER(G) (SCM_PACK (SCM_STRUCT_DATA (G) [scm_si_generic_setter]))
#define SCM_SET_GENERIC_SETTER(G,C) (SCM_STRUCT_DATA (G) [scm_si_generic_setter] = SCM_UNPACK (C))
-#define SCM_INITIAL_MCACHE_SIZE 1
-
#define scm_si_dispatch_procedure scm_applicable_struct_index_procedure /* 0 */
#define scm_si_methods 1
#define scm_si_n_specialized 2
@@ -301,7 +297,6 @@ SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
SCM_API SCM scm_sys_invalidate_class (SCM cls);
-SCM_API SCM scm_make_method_cache (SCM gf);
SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
SCM_API SCM scm_generic_capability_p (SCM proc);
SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
@@ -313,9 +308,6 @@ SCM_API SCM scm_make (SCM args);
SCM_API SCM scm_find_method (SCM args);
SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);
SCM_API void scm_change_object_class (SCM, SCM, SCM);
-SCM_API SCM scm_memoize_method (SCM x, SCM args);
-SCM_API SCM scm_mcache_lookup_cmethod (SCM cache, SCM args);
-SCM_API SCM scm_mcache_compute_cmethod (SCM cache, SCM args);
/* The following are declared in __scm.h
SCM_API SCM scm_call_generic_0 (SCM gf);
SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 59a5520f7..1f376ab70 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -766,17 +766,6 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_call;
}
- if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM args = SCM_EOL;
- int n = nargs;
- SCM* walk = sp;
- SYNC_REGISTER ();
- while (n--)
- args = scm_cons (*walk--, args);
- *walk = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (x), args);
- goto vm_call;
- }
/*
* Other interpreted or compiled call
*/
@@ -855,17 +844,6 @@ VM_DEFINE_INSTRUCTION (54, goto_args, "goto/args", 1, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_goto_args;
}
- if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM args = SCM_EOL;
- int n = nargs;
- SCM* walk = sp;
- SYNC_REGISTER ();
- while (n--)
- args = scm_cons (*walk--, args);
- *walk = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (x), args);
- goto vm_goto_args;
- }
/*
* Other interpreted or compiled call
@@ -952,17 +930,6 @@ VM_DEFINE_INSTRUCTION (57, mv_call, "mv-call", 4, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_mv_call;
}
- if (SCM_STRUCTP (x) && SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_PURE_GENERIC)
- {
- SCM args = SCM_EOL;
- int n = nargs;
- SCM* walk = sp;
- SYNC_REGISTER ();
- while (n--)
- args = scm_cons (*walk--, args);
- *walk = scm_mcache_compute_cmethod (SCM_GENERIC_METHOD_CACHE (x), args);
- goto vm_mv_call;
- }
/*
* Other interpreted or compiled call
*/
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index 9e97b5b71..df7680028 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -228,7 +228,7 @@
(cache-miss gf args)))
(define (cache-miss gf args)
- (apply (memoize-method! gf args (slot-ref gf '%cache)) args))
+ (apply (memoize-method! gf args) args))
(define (memoize-effective-method! gf args applicable)
(define (first-n ls n)
@@ -256,7 +256,7 @@
;;; Memoization
;;;
-(define (memoize-method! gf args exp)
+(define (memoize-method! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods
compute-applicable-methods)