summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/eval.c316
-rw-r--r--srfi/srfi-1.c3
-rw-r--r--test-suite/tests/sort.test6
-rw-r--r--test-suite/tests/srfi-1.test28
4 files changed, 30 insertions, 323 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 7152322e1..ac4c7347a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -3197,328 +3197,34 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
/* 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.
+ * Trampolines were an intent to speed up calling the same Scheme procedure many
+ * times from C.
*
- * 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).
+ * However, this was the wrong thing to optimize; if you really know what you're
+ * calling, call its function directly, otherwise you're in Scheme-land, and we
+ * have many better tricks there (inlining, for example, which can remove the
+ * need for closures and free variables).
*
- * Applying the optimization to map and for-each increased efficiency
- * noticeably. For example, (map abs ls) is now 8 times faster than
- * before.
+ * Also, in the normal debugging case, trampolines were being computed but not
+ * used. Silliness.
*/
-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)
-{
- const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- SCM_EOL,
- SCM_ENV (proc));
- const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
- return result;
-}
-
scm_t_trampoline_0
scm_trampoline_0 (SCM proc)
{
- scm_t_trampoline_0 trampoline;
-
- if (SCM_IMP (proc))
- return NULL;
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_0:
- trampoline = call_subr0_0;
- break;
- case scm_tc7_subr_1o:
- trampoline = call_subr1o_0;
- break;
- case scm_tc7_lsubr:
- trampoline = call_lsubr_0;
- break;
- case scm_tcs_closures:
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (scm_is_null (formals) || !scm_is_pair (formals))
- trampoline = scm_i_call_closure_0;
- else
- return NULL;
- break;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- trampoline = scm_call_generic_0;
- else if (SCM_STRUCT_APPLICABLE_P (proc))
- trampoline = scm_call_0;
- else
- return NULL;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0;
- else
- return NULL;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_gsubr:
- case scm_tc7_pws:
- case scm_tc7_program:
- trampoline = scm_call_0;
- break;
- default:
- return NULL; /* not applicable on zero arguments */
- }
- /* We only reach this point if a valid trampoline was determined. */
-
- /* If debugging is enabled, we want to see all calls to proc on the stack.
- * Thus, we replace the trampoline shortcut with scm_call_0. */
- if (scm_debug_mode_p)
- return scm_call_0;
- else
- return trampoline;
-}
-
-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_I_INUMP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
- }
- else if (SCM_REALP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
- }
- else if (SCM_BIGP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
- }
- else if (SCM_FRACTIONP (arg1))
- {
- return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
- }
- SCM_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1);
-}
-
-static SCM
-call_cxr_1 (SCM proc, SCM arg1)
-{
- return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
-}
-
-static SCM
-call_closure_1 (SCM proc, SCM arg1)
-{
- const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_1 (arg1),
- SCM_ENV (proc));
- const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
- return result;
+ return scm_call_0;
}
scm_t_trampoline_1
scm_trampoline_1 (SCM proc)
{
- scm_t_trampoline_1 trampoline;
-
- if (SCM_IMP (proc))
- return NULL;
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_1:
- case scm_tc7_subr_1o:
- trampoline = call_subr1_1;
- break;
- case scm_tc7_subr_2o:
- trampoline = call_subr2o_1;
- break;
- case scm_tc7_lsubr:
- trampoline = call_lsubr_1;
- break;
- case scm_tc7_dsubr:
- trampoline = call_dsubr_1;
- break;
- case scm_tc7_cxr:
- trampoline = call_cxr_1;
- break;
- case scm_tcs_closures:
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (!scm_is_null (formals)
- && (!scm_is_pair (formals) || !scm_is_pair (SCM_CDR (formals))))
- trampoline = call_closure_1;
- else
- return NULL;
- break;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- trampoline = scm_call_generic_1;
- else if (SCM_STRUCT_APPLICABLE_P (proc))
- trampoline = scm_call_1;
- else
- return NULL;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1;
- else
- return NULL;
- break;
- case scm_tc7_asubr:
- case scm_tc7_rpsubr:
- case scm_tc7_gsubr:
- case scm_tc7_pws:
- case scm_tc7_program:
- trampoline = scm_call_1;
- break;
- default:
- return NULL; /* not applicable on one arg */
- }
- /* We only reach this point if a valid trampoline was determined. */
-
- /* If debugging is enabled, we want to see all calls to proc on the stack.
- * Thus, we replace the trampoline shortcut with scm_call_1. */
- if (scm_debug_mode_p)
- return scm_call_1;
- else
- return trampoline;
-}
-
-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)
-{
- const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
- scm_list_2 (arg1, arg2),
- SCM_ENV (proc));
- const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
- return result;
+ return scm_call_1;
}
scm_t_trampoline_2
scm_trampoline_2 (SCM proc)
{
- scm_t_trampoline_2 trampoline;
-
- if (SCM_IMP (proc))
- return NULL;
-
- switch (SCM_TYP7 (proc))
- {
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
- trampoline = call_subr2_2;
- break;
- case scm_tc7_lsubr_2:
- trampoline = call_lsubr2_2;
- break;
- case scm_tc7_lsubr:
- trampoline = call_lsubr_2;
- break;
- case scm_tcs_closures:
- {
- SCM formals = SCM_CLOSURE_FORMALS (proc);
- if (!scm_is_null (formals)
- && (!scm_is_pair (formals)
- || (!scm_is_null (SCM_CDR (formals))
- && (!scm_is_pair (SCM_CDR (formals))
- || !scm_is_pair (SCM_CDDR (formals))))))
- trampoline = call_closure_2;
- else
- return NULL;
- break;
- }
- case scm_tcs_struct:
- if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
- trampoline = scm_call_generic_2;
- else if (SCM_STRUCT_APPLICABLE_P (proc))
- trampoline = scm_call_2;
- else
- return NULL;
- break;
- case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2;
- else
- return NULL;
- break;
- case scm_tc7_gsubr:
- case scm_tc7_pws:
- case scm_tc7_program:
- trampoline = scm_call_2;
- break;
- default:
- return NULL; /* not applicable on two args */
- }
- /* We only reach this point if a valid trampoline was determined. */
-
- /* If debugging is enabled, we want to see all calls to proc on the stack.
- * Thus, we replace the trampoline shortcut with scm_call_2. */
- if (scm_debug_mode_p)
- return scm_call_2;
- else
- return trampoline;
+ return scm_call_2;
}
/* Typechecking for multi-argument MAP and FOR-EACH.
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index 02f46fca0..069f213d8 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -1,6 +1,6 @@
/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008
+ * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006, 2008, 2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -1330,6 +1330,7 @@ SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
int argnum;
SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_PROC (SCM_ARG1, equal);
SCM_VALIDATE_REST_ARGUMENT (rest);
ret = SCM_EOL;
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 292836d88..4223b923f 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -1,5 +1,5 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
-;;;; Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2007, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -24,11 +24,11 @@
(with-test-prefix "sort"
(pass-if-exception "less function taking less than two arguments"
- exception:wrong-type-arg
+ exception:wrong-num-args
(sort '(1 2) (lambda (x) #t)))
(pass-if-exception "less function taking more than two arguments"
- exception:wrong-type-arg
+ exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
(pass-if "sort!"
diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index c163e7b69..ecff82f43 100644
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1,6 +1,6 @@
;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -507,9 +507,9 @@
(pass-if "empty list" (= 0 (count or1 '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(count (lambda () x) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 2" exception:wrong-num-args
(count (lambda (x y) x) '(1 2 3)))
(pass-if-exception "improper 1" exception:wrong-type-arg
@@ -545,11 +545,11 @@
(pass-if "empty lists" (= 0 (count or2 '() '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(count (lambda () #t) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 1" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 1" exception:wrong-num-args
(count (lambda (x) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 3" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 3" exception:wrong-num-args
(count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
(pass-if-exception "improper first 1" exception:wrong-type-arg
@@ -1146,11 +1146,11 @@
(pass-if "empty list" (= 123 (fold + 123 '())))
- (pass-if-exception "proc arg count 0" exception:wrong-type-arg
+ (pass-if-exception "proc arg count 0" exception:wrong-num-args
(fold (lambda () x) 123 '(1 2 3)))
- (pass-if-exception "proc arg count 1" exception:wrong-type-arg
+ (pass-if-exception "proc arg count 1" exception:wrong-num-args
(fold (lambda (x) x) 123 '(1 2 3)))
- (pass-if-exception "proc arg count 3" exception:wrong-type-arg
+ (pass-if-exception "proc arg count 3" exception:wrong-num-args
(fold (lambda (x y z) x) 123 '(1 2 3)))
(pass-if-exception "improper 1" exception:wrong-type-arg
@@ -1406,9 +1406,9 @@
(pass-if "empty list" (eq? #f (list-index symbol? '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(list-index (lambda () x) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 2" exception:wrong-num-args
(list-index (lambda (x y) x) '(1 2 3)))
(pass-if-exception "improper 1" exception:wrong-type-arg
@@ -1444,11 +1444,11 @@
(pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
- (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
(list-index (lambda () #t) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 1" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 1" exception:wrong-num-args
(list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 3" exception:wrong-type-arg
+ (pass-if-exception "pred arg count 3" exception:wrong-num-args
(list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
(pass-if-exception "improper first 1" exception:wrong-type-arg