summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMikael Djurfeldt <djurfeldt@nada.kth.se>2002-12-01 13:09:26 +0000
committerMikael Djurfeldt <djurfeldt@nada.kth.se>2002-12-01 13:09:26 +0000
commit504d99c5f8e72c5640810eac181755a331a53c15 (patch)
treee422c776a60707bec56f4e4e691264d2edd6ff9e
parent0359fc922c62c4ee45b504a970e2763c2b180a4c (diff)
downloadguile-504d99c5f8e72c5640810eac181755a331a53c15.tar.gz
* eval.h (scm_t_trampoline_1, scm_t_trampoline_2): New types.
* eval.c, eval.h (scm_trampoline_1, scm_trampoline_2): New functions. * eval.c (call_subr2_2, call_lsubr_2, call_closure_2): New functions; (map, for-each): Handle also application on two args as a special case; Use trampolines. * sort.c (scm_cmp_function): Choose subr2less for scm_tc7_subr_2o; (subr2oless): Removed. (scm_restricted_vector_sort_x): Use scm_return_first to keep the vector GC protected. * eval.c (check_map_args): Use scm_out_of_range_pos instead of scm_out_of_range.
-rw-r--r--libguile/ChangeLog49
-rw-r--r--libguile/eval.c237
-rw-r--r--libguile/eval.h7
-rw-r--r--libguile/sort.c15
4 files changed, 284 insertions, 24 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 5b2c69491..0ff696204 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,36 @@
+2002-12-01 Mikael Djurfeldt <mdj@linnaeus>
+
+ The following change makes 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 increases efficiency
+ noticeably. For example, (map abs ls) is 8 times faster than
+ before.
+
+ * eval.h (scm_t_trampoline_1, scm_t_trampoline_2): New types.
+
+ * eval.c, eval.h (scm_trampoline_1, scm_trampoline_2): New functions.
+
+ * eval.c (call_subr2_2, call_lsubr_2, call_closure_2): New functions;
+ (map, for-each): Handle also application on two args as a special
+ case; Use trampolines.
+
+ Other changes:
+
+ * sort.c (scm_cmp_function): Choose subr2less for scm_tc7_subr_2o;
+ (subr2oless): Removed.
+ (scm_restricted_vector_sort_x): Use scm_return_first to keep the
+ vector GC protected.
+
+ * eval.c (check_map_args): Use scm_out_of_range_pos instead of
+ scm_out_of_range.
+
2002-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
* evalext.[ch] (scm_m_undefine, undefine): Deprecated.
@@ -290,7 +323,7 @@
2002-10-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
- * async.c (s_scm_system_async_mark_for_thread): Only call
+ * async.c (scm_system_async_mark_for_thread): Only call
scm_i_thread_root when USE_THREADS is defined. Use scm_root
otherwise.
@@ -367,7 +400,7 @@
* Makefile.am (libguile_la_LIBADD): switch to use
libguile-ltdl.la.
- * numbers.c (s_scm_integer_expt): (expt 0 1) should be 1.
+ * numbers.c (scm_integer_expt): (expt 0 1) should be 1.
2002-10-04 Marius Vollmer <mvo@zagadka.ping.de>
@@ -627,10 +660,10 @@
scm_add_to_port_table. This prevents cells with null-pointers from
being exposed to GC.
- * vports.c (s_scm_make_soft_port) strports.c (scm_mkstrport),
+ * vports.c (scm_make_soft_port) strports.c (scm_mkstrport),
fports.c (scm_fdes_to_port): Use scm_new_port_table_entry().
- * gc.c (s_scm_gc_stats): add cell-yield and malloc-yield statistic
+ * gc.c (scm_gc_stats): add cell-yield and malloc-yield statistic
to gc-stats.
* numbers.c (big2str): return "0" for 0 iso. ""
@@ -667,9 +700,9 @@
* macros.c: include deprecation.h
- * vectors.c (s_scm_vector_move_right_x): remove side effect in
+ * vectors.c (scm_vector_move_right_x): remove side effect in
macro arg.
- (s_scm_vector_move_left_x): idem.
+ (scm_vector_move_left_x): idem.
* net_db.c, posix.c, socket.c: variable naming: change ans to
result.
@@ -878,7 +911,7 @@
* goops.h (scm_slot_exists_p): Rename from scm_slots_exists_p.
* goops.c (scm_slot_exists_p): Rename from scm_slots_exists_p.
- (s_scm_slot_exists_p): Rename from s_scm_slots_exists_p.
+ (scm_slot_exists_p): Rename from scm_slots_exists_p.
Thanks to Andreas Rottmann.
2002-04-20 Gary Houston <ghouston@arglist.com>
@@ -1344,7 +1377,7 @@
* socket.c: Include `stdint.h' if available for the `uint32_t'
declaration.
- * scmsigs.c (s_scm_sigaction): Initialize `chandler' (inhibits
+ * scmsigs.c (scm_sigaction): Initialize `chandler' (inhibits
compiler warning).
* backtrace.c: Include `lang.h' for GUILE_DEBUG conditional.
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;
}
diff --git a/libguile/eval.h b/libguile/eval.h
index 43d967ab3..ec4dc476f 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -3,7 +3,7 @@
#ifndef SCM_EVAL_H
#define SCM_EVAL_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -130,6 +130,9 @@ SCM_API SCM scm_eval_options_interface (SCM setting);
#define SCM_XEVALCAR(x, env) EVALCAR (x, env)
#endif /* DEBUG_EXTENSIONS */
+typedef SCM (*scm_t_trampoline_1) (SCM proc, SCM arg1);
+typedef SCM (*scm_t_trampoline_2) (SCM proc, SCM arg1, SCM arg2);
+
#define SCM_EXTEND_ENV scm_acons
@@ -224,6 +227,8 @@ SCM_API SCM scm_apply_0 (SCM proc, SCM args);
SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
+SCM_API scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
+SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args);
diff --git a/libguile/sort.c b/libguile/sort.c
index 9e547e764..f5b89f51f 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001,2002 Free Software Foundation, Inc.
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
@@ -356,14 +356,6 @@ subr2less (SCM less, const void *a, const void *b)
} /* subr2less */
static int
-subr2oless (SCM less, const void *a, const void *b)
-{
- return SCM_NFALSEP (SCM_SUBRF (less) (*(SCM *) a,
- *(SCM *) b,
- SCM_UNDEFINED));
-} /* subr2oless */
-
-static int
lsubrless (SCM less, const void *a, const void *b)
{
return SCM_NFALSEP (SCM_SUBRF (less)
@@ -394,11 +386,10 @@ scm_cmp_function (SCM p)
switch (SCM_TYP7 (p))
{
case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
case scm_tc7_rpsubr:
case scm_tc7_asubr:
return subr2less;
- case scm_tc7_subr_2o:
- return subr2oless;
case scm_tc7_lsubr:
return lsubrless;
case scm_tcs_closures:
@@ -438,7 +429,7 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
quicksort (&vp[spos], len, size, scm_cmp_function (less), less);
- return SCM_UNSPECIFIED;
+ return scm_return_first (SCM_UNSPECIFIED, vec);
/* return vec; */
}
#undef FUNC_NAME