mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-31 17:30:24 +02:00
Code Activity

generics now dispatch as applicable structs

Browse source 
* libguile/eval.i.c (CEVAL, SCM_APPLY): Dispatch applicable structs
  before pure generics. In practice what this means is that we never hit
  the mcache case, because all pure generics are applicable structs.
  We're moving over to having generics dispatch themselves. Also, they
  don't prepend the struct as an arg; in order to have that effect, the
  user has closures.

* libguile/goops.c (scm_apply_generic, scm_call_generic_0):
  (scm_call_generic_1, scm_call_generic_2, scm_call_generic_3): Dispatch
  directly to the struct procedures.
  (scm_var_make_extended_generic): Remove a duplicate definition for
  scm_var_make_extended_generic.
  (create_standard_classes): Mark all instances of
  <applicable-struct-class> (themselves classes) as applicable classes.
  Meaning: generics are now applicable structs.

* libguile/goops.h (SCM_CLASS_CLASS_LAYOUT): The hashsets are actually
  uw slots -- or at least, making subclasses maps the int slots to be uw
  slots

* libguile/vm-i-system.c (call, goto/args, mv-call): Dispatch applicable
  structs in the VM.

* module/oop/goops/dispatch.scm (emit-linear-dispatch): Fix bug in the
  non-rest cache miss case.
  (delayed-compile): Rework to avoid fluids.
  (cache-dispatch): Don't call `equal?', it causes bootstrapping
  problems with the primitive-generic equal?. Using our own version is
  faster anyway.
This commit is contained in:
Andy Wingo 2009-11-20 13:11:52 +01:00
parent 9f63ce021c
commit 2f652c6884
5 changed files with 107 additions and 112 deletions
Download patch file Download diff file Expand all files Collapse all files

115
libguile/eval.i.c
View file

@ -1026,22 +1026,20 @@ dispatch:
goto nontoplevel_begin;
}
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
if (SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.info->a.proc = proc;
#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 if (SCM_STRUCT_APPLICABLE_P (proc))
{
arg1 = proc;
proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.info->a.proc = proc;
debug.info->a.args = scm_list_1 (arg1);
#endif
goto evap1;
}
else
goto badfun;
case scm_tc7_subr_1:
@ -1153,7 +1151,15 @@ dispatch:
goto nontoplevel_begin;
}
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
if (SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.info->a.proc = proc;
#endif
goto evap1;
}
else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_GENERIC_METHOD_CACHE (proc);
#ifdef DEVAL
@ -1163,17 +1169,6 @@ dispatch:
#endif
goto type_dispatch;
}
else if (SCM_STRUCT_APPLICABLE_P (proc))
{
arg2 = arg1;
arg1 = proc;
proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.info->a.args = scm_cons (arg1, debug.info->a.args);
debug.info->a.proc = proc;
#endif
goto evap2;
}
else
goto badfun;
case scm_tc7_subr_2:
@ -1232,7 +1227,24 @@ dispatch:
RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
#endif
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
if (SCM_STRUCT_APPLICABLE_P (proc))
{
operatorn:
#ifdef DEVAL
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
debug.info->a.args,
SCM_EOL));
#else
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
scm_cons (arg1,
scm_cons (arg2,
scm_ceval_args (x,
env,
proc))),
SCM_EOL));
#endif
}
else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
x = SCM_GENERIC_METHOD_CACHE (proc);
#ifdef DEVAL
@ -1242,23 +1254,6 @@ dispatch:
#endif
goto type_dispatch;
}
else if (SCM_STRUCT_APPLICABLE_P (proc))
{
operatorn:
#ifdef DEVAL
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
scm_cons (proc, debug.info->a.args),
SCM_EOL));
#else
RETURN (SCM_APPLY (SCM_STRUCT_PROCEDURE (proc),
scm_cons2 (proc, arg1,
scm_cons (arg2,
scm_ceval_args (x,
env,
proc))),
SCM_EOL));
#endif
}
else
goto badfun;
case scm_tc7_subr_0:
@ -1458,7 +1453,9 @@ dispatch:
}
#endif /* DEVAL */
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
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;
@ -1468,8 +1465,6 @@ dispatch:
x = SCM_GENERIC_METHOD_CACHE (proc);
goto type_dispatch;
}
else if (SCM_STRUCT_APPLICABLE_P (proc))
goto operatorn;
else
goto badfun;
case scm_tc7_subr_2:
@ -1764,7 +1759,18 @@ tail:
#endif
goto tail;
case scm_tcs_struct:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
if (SCM_STRUCT_APPLICABLE_P (proc))
{
proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.vect[0].a.proc = proc;
#endif
if (SCM_NIMP (proc))
goto tail;
else
goto badproc;
}
else if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
{
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
@ -1773,25 +1779,6 @@ tail:
#endif
RETURN (scm_apply_generic (proc, args));
}
else if (SCM_STRUCT_APPLICABLE_P (proc))
{
/* operator */
#ifdef DEVAL
args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
arg1 = proc;
proc = SCM_STRUCT_PROCEDURE (proc);
#ifdef DEVAL
debug.vect[0].a.proc = proc;
debug.vect[0].a.args = scm_cons (arg1, args);
#endif
if (SCM_NIMP (proc))
goto tail;
else
goto badproc;
}
else
goto badproc;
default: