summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c237
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;
}