diff options
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 237 |
1 files changed, 234 insertions, 3 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index e775a0ce8..7bdedd0d3 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -3689,6 +3689,7 @@ tail: goto badproc; else { + /* operator */ #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); #else @@ -3748,6 +3749,193 @@ ret: #ifndef DEVAL +/* Trampolines + * + * Trampolines make it possible to move procedure application dispatch + * outside inner loops. The motivation was clean implementation of + * efficient replacements of R5RS primitives in SRFI-1. + * + * The semantics is clear: scm_trampoline_N returns an optimized + * version of scm_call_N (or NULL if the procedure isn't applicable + * on N args). + * + * Applying the optimization to map and for-each increased efficiency + * noticeably. For example, (map abs ls) is now 8 times faster than + * before. + */ + +static SCM +call_subr1_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (arg1); +} + +static SCM +call_lsubr_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (scm_list_1 (arg1)); +} + +static SCM +call_dsubr_1 (SCM proc, SCM arg1) +{ + if (SCM_INUMP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } +#ifdef SCM_BIGDIG + else if (SCM_BIGP (arg1)) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); +#endif + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); +} + +static SCM +call_cxr_1 (SCM proc, SCM arg1) +{ + proc = SCM_SNAME (proc); + { + char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; + while ('c' != *--chrs) + { + SCM_ASSERT (SCM_CONSP (arg1), + arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); + arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); + } + return (arg1); + } +} + +static SCM +call_closure_1 (SCM proc, SCM arg1) +{ + return scm_eval_body (SCM_CLOSURE_BODY (proc), + SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_1 (arg1), + SCM_ENV (proc))); +} + +scm_t_trampoline_1 +scm_trampoline_1 (SCM proc) +{ + if (SCM_IMP (proc)) + return 0; + if (SCM_DEBUGGINGP) + return scm_call_1; + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + return call_subr1_1; + case scm_tc7_lsubr: + return call_lsubr_1; + case scm_tc7_cxr: + if (SCM_SUBRF (proc)) + return call_dsubr_1; + else + return call_cxr_1; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (!SCM_CONSP (formals) || SCM_NULLP (SCM_CDR (formals))) + return call_closure_1; + else + return 0; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + return scm_call_generic_1; + else if (!SCM_I_OPERATORP (proc)) + return 0; + return scm_call_1; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + return SCM_SMOB_DESCRIPTOR (proc).apply_1; + else + return 0; + /* fall through */ + case scm_tc7_asubr: + case scm_tc7_rpsubr: + case scm_tc7_cclo: + case scm_tc7_pws: + return scm_call_1; + default: + return 0; /* not applicable on one arg */ + } +} + +static SCM +call_subr2_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (arg1, arg2); +} + +static SCM +call_lsubr_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)); +} + +static SCM +call_closure_2 (SCM proc, SCM arg1, SCM arg2) +{ + return scm_eval_body (SCM_CLOSURE_BODY (proc), + SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_2 (arg1, arg2), + SCM_ENV (proc))); +} + +scm_t_trampoline_2 +scm_trampoline_2 (SCM proc) +{ + if (SCM_IMP (proc)) + return 0; + if (SCM_DEBUGGINGP) + return scm_call_2; + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + case scm_tc7_rpsubr: + case scm_tc7_asubr: + return call_subr2_2; + case scm_tc7_lsubr: + return call_lsubr_2; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (!SCM_CONSP (formals) + || (SCM_CONSP (SCM_CDR (formals)) + && SCM_NULLP (SCM_CDDR (formals)))) + return call_closure_2; + else + return 0; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + return scm_call_generic_2; + else if (!SCM_I_OPERATORP (proc)) + return 0; + return scm_call_2; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + return SCM_SMOB_DESCRIPTOR (proc).apply_2; + else + return 0; + /* fall through */ + case scm_tc7_cclo: + case scm_tc7_pws: + return scm_call_2; + default: + return 0; /* not applicable on two args */ + } +} + /* Typechecking for multi-argument MAP and FOR-EACH. Verify that each element of the vector ARGV, except for the first, @@ -3777,7 +3965,7 @@ check_map_args (SCM argv, } if (elt_len != len) - scm_out_of_range (who, ve[i]); + scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2)); } scm_remember_upto_here_1 (argv); @@ -3808,11 +3996,33 @@ scm_map (SCM proc, SCM arg1, SCM args) SCM_VALIDATE_REST_ARGUMENT (args); if (SCM_NULLP (args)) { + scm_t_trampoline_1 call = scm_trampoline_1 (proc); + SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map); + while (SCM_NIMP (arg1)) + { + *pres = scm_list_1 (call (proc, SCM_CAR (arg1))); + pres = SCM_CDRLOC (*pres); + arg1 = SCM_CDR (arg1); + } + return res; + } + if (SCM_NULLP (SCM_CDR (args))) + { + SCM arg2 = SCM_CAR (args); + int len2 = scm_ilength (arg2); + scm_t_trampoline_2 call = scm_trampoline_2 (proc); + SCM_GASSERTn (call, + g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map); + SCM_GASSERTn (len2 >= 0, + g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map); + if (len2 != len) + SCM_OUT_OF_RANGE (3, arg2); while (SCM_NIMP (arg1)) { - *pres = scm_list_1 (scm_apply (proc, SCM_CAR (arg1), scm_listofnull)); + *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2))); pres = SCM_CDRLOC (*pres); arg1 = SCM_CDR (arg1); + arg2 = SCM_CDR (arg2); } return res; } @@ -3850,10 +4060,31 @@ scm_for_each (SCM proc, SCM arg1, SCM args) SCM_VALIDATE_REST_ARGUMENT (args); if (SCM_NULLP (args)) { + scm_t_trampoline_1 call = scm_trampoline_1 (proc); + SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each); + while (SCM_NIMP (arg1)) + { + call (proc, SCM_CAR (arg1)); + arg1 = SCM_CDR (arg1); + } + return SCM_UNSPECIFIED; + } + if (SCM_NULLP (SCM_CDR (args))) + { + SCM arg2 = SCM_CAR (args); + int len2 = scm_ilength (arg2); + scm_t_trampoline_2 call = scm_trampoline_2 (proc); + SCM_GASSERTn (call, g_for_each, + scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each); + SCM_GASSERTn (len2 >= 0, g_for_each, + scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each); + if (len2 != len) + SCM_OUT_OF_RANGE (3, arg2); while (SCM_NIMP (arg1)) { - scm_apply (proc, SCM_CAR (arg1), scm_listofnull); + call (proc, SCM_CAR (arg1), SCM_CAR (arg2)); arg1 = SCM_CDR (arg1); + arg2 = SCM_CDR (arg2); } return SCM_UNSPECIFIED; } |