+/* 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_subr0_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) ();
+}
+
+static SCM
+call_subr1o_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) (SCM_UNDEFINED);
+}
+
+static SCM
+call_lsubr_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) (SCM_EOL);
+}
+
+SCM
+scm_i_call_closure_0 (SCM proc)
+{
+ return scm_eval_body (SCM_CLOSURE_BODY (proc),
+ SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ SCM_EOL,
+ SCM_ENV (proc)));
+}
+
+scm_t_trampoline_0
+scm_trampoline_0 (SCM proc)
+{
+ if (SCM_IMP (proc))
+ return 0;
+ if (SCM_DEBUGGINGP)
+ return scm_call_0;
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_0:
+ return call_subr0_0;
+ case scm_tc7_subr_1o:
+ return call_subr1o_0;
+ case scm_tc7_lsubr:
+ return call_lsubr_0;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_NULLP (formals) || !SCM_CONSP (formals))
+ return scm_i_call_closure_0;
+ else
+ return 0;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ return scm_call_generic_0;
+ else if (!SCM_I_OPERATORP (proc))
+ return 0;
+ return scm_call_0;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ return SCM_SMOB_DESCRIPTOR (proc).apply_0;
+ else
+ return 0;
+ /* fall through */
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ return scm_call_0;
+ default:
+ return 0; /* not applicable on one arg */
+ }
+}
+
+static SCM
+call_subr1_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (arg1);
+}
+
+static SCM
+call_subr2o_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+}
+
+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_subr_2o:
+ return call_subr2o_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_NULLP (formals)
+ && (!SCM_CONSP (formals) || !SCM_CONSP (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_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
+}
+
+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_2:
+ return call_lsubr2_2;
+ case scm_tc7_lsubr:
+ return call_lsubr_2;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (!SCM_NULLP (formals)
+ && (!SCM_CONSP (formals)
+ || (!SCM_NULLP (SCM_CDR (formals))
+ && (!SCM_CONSP (SCM_CDR (formals))
+ || !SCM_CONSP (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 */
+ }
+}
+