gut trampolines

* libguile/eval.c: Gut the trampoline implementation. We'll be doing
  much more clever things here that will obviate the need for the
  procedure arg of map and for-each to be allocated in many cases...
  trampolines were a noble attempt at optimizing in the wrong place.

* srfi/srfi-1.c (scm_srfi1_lset_difference_x): Validate that we get a
  proc, because the trampoline won't do it for us.

* test-suite/tests/sort.test ("sort"):
* test-suite/tests/srfi-1.test ("count", "fold", "list-index"):
  Change expected exceptions, due to trampoline functions not doing any
  computation.

diff --git a/libguile/eval.c b/libguile/eval.c
index 7152322..ac4c734 100644 (file)
--- 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 02f46fc..069f213 100644 (file)
--- 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 292836d..4223b92 100644 (file)
--- 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 c163e7b..ecff82f 100644 (file)
--- 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