mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

gut trampolines

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-08-21 00:38:48 +02:00
parent 81b30a35f7
commit 95e5998204
4 changed files with 30 additions and 323 deletions
Download patch file Download diff file Expand all files Collapse all files

316
libguile/eval.c
View file

@ -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.

3
srfi/srfi-1.c
View file

@ -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;

6
test-suite/tests/sort.test
View file

@ -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!"

28
test-suite/tests/srfi-1.test
View file

@ -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