diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2002-12-01 13:09:26 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2002-12-01 13:09:26 +0000 |
commit | 504d99c5f8e72c5640810eac181755a331a53c15 (patch) | |
tree | e422c776a60707bec56f4e4e691264d2edd6ff9e | |
parent | 0359fc922c62c4ee45b504a970e2763c2b180a4c (diff) | |
download | guile-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/ChangeLog | 49 | ||||
-rw-r--r-- | libguile/eval.c | 237 | ||||
-rw-r--r-- | libguile/eval.h | 7 | ||||
-rw-r--r-- | libguile/sort.c | 15 |
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 |