[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Inlining calls to primitives
|
From: |
Ludovic Courtès |
|
Subject: |
Inlining calls to primitives |
|
Date: |
Tue, 29 Aug 2006 10:48:53 +0200 |
|
User-agent: |
Gnus/5.110006 (No Gnus v0.6) Emacs/21.4 (gnu/linux) |
Hi,
I conducted an experiment with the evaluator consisting in implementing
"inlining" of calls to a few primitive procedures and I'd like to get
feedback about it.
"Inlining" means that `CEVAL ()' was augmented with an internal
implementation of these primitives (in the form built-in macros), and
that the call sites of these primitives are modified to use them (i.e.,
by automatically have them use the corresponding built-in macro).
Although this is not strictly R5RS-compatible, most implementations have
a similar feature (e.g., S48's `inline-values' [0]).
I made experiments with the following "inlinables": `not', `eq?',
`null?', `list?', `cons', `pair?', `car', `cdr' (thus I added a built-in
macro for each of those: address@hidden', address@hidden', etc.). I chose a
program
likely to benefit from this optimization, one that uses `every' from
`srfi-1.scm':
(eval-enable 'inline) ;; switch me!
(define %lst (iota 2000000))
(use-modules (srfi srfi-1))
(let ((start (get-internal-run-time)))
(every number? %lst)
(let ((end (get-internal-run-time)))
(format #t "time: ~a~%" (- end start))))
(exit)
Without inlining:
$ time ./pre-inst-guile -l ,,every.scm
time: 1282
real 0m24.815s
user 0m24.002s
sys 0m0.614s
With inlining:
$ time ./pre-inst-guile -l ,,every.scm
time: 922
real 0m19.714s
user 0m19.067s
sys 0m0.484s
So the improvement is around 28% for the time spent in `every' itself,
and it's "only" 20% for the time spent in the whole program. Of course,
for "real" programs (e.g., the test suite), the improvement is even less
noticeable, or even close to 0. But still, these results might be
considered a sufficiently good incentive against, say, Kevin's
C-rewriting of SRFI-1. ;-)
The patch is actually two-fold:
1. It adds a new file, `built-in.i', that contains declarations of
built-in macros. This file is then processed by `extract-imsyms.h'
that create declarations of the corresponding immediate symbols.
Also, `built-in-expand.h' contains macrology (inspired by Guile-VM)
that can extract various things from `built-in.i' for use in
`eval.c': table of built-in macro names, table of unmemoizers, and
dispatch tables.
When GCC is used, dispatch tables can be produced instead of
`switch' (using GCC's labels-as-pointers extension). This makes
immediate-symbol dispatching slightly faster.
2. It introduces new built-in macros (address@hidden', etc.), code to
actually perform the inlining in `eval.c', a new option for
`eval-options', as well as a new snarfing macro,
`SCM_DEFINE_INLINABLE', that is used by inlinable primitives.
The `scm_t_subr_entry' type is modified to contain information
relative to inlinables, allowing for the inlining itself to be O(1)
wrt. to the number of inlinable procedures; the subr and gsubr APIs
are also extended to make use of this.
I'm attaching the files and patch (unclean) below, but this can
otherwise be fetched using Arch:
$ tla register-archive http://www.laas.fr/~lcourtes/software/arch-2005/
$ tla get \
address@hidden/guile-core--eval-o1-dispatch--1.9 \
guile-core-with-inlining
Comments and criticism welcome!
Thanks,
Ludovic.
PS: As a side-effect, the patch also makes `eq?' strictly binary (as
required by R5RS and documented in the manual), hence the change in
`syntax.test'.
PS2: BTW, inling `scm_ilookup ()' also has a noticeable impact!
[0] http://s48.org/1.3/manual/manual-Z-H-4.html#node_sec_2.4
The patch:
--- orig/libguile/Makefile.am
+++ mod/libguile/Makefile.am
@@ -26,7 +26,7 @@
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building.
-INCLUDES = -I.. -I$(top_srcdir)
+INCLUDES = -I.. -I$(top_srcdir) -I$(top_builddir)/libguile
ETAGS_ARGS =
--regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/'
\
--regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/'
@@ -64,6 +64,10 @@
rm -f scmconfig.h
mv scmconfig.h.tmp scmconfig.h
+imsyms.h: $(srcdir)/built-in.i
+ $(srcdir)/extract-imsyms.sh $^ > $@
+
+
guile_filter_doc_snarfage_SOURCES = c-tokenize.c
## Override default rule; this should be compiled for BUILD host.
@@ -146,7 +150,7 @@
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
- version.h scmconfig.h \
+ version.h scmconfig.h imsyms.h \
$(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
EXTRA_libguile_la_SOURCES = _scm.h \
@@ -207,12 +211,14 @@
# and people feel like maintaining them. For now, this is not the case.
noinst_SCRIPTS = guile-doc-snarf guile-snarf-docs guile-func-name-check
-EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \
- ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c \
+EXTRA_DIST = ChangeLog-gh ChangeLog-scm ChangeLog-threads \
+ ChangeLog-1996-1999 ChangeLog-2000 cpp_signal.c \
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
- cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
- c-tokenize.lex version.h.in \
- scmconfig.h.top gettext.h
+ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
+ c-tokenize.lex version.h.in \
+ scmconfig.h.top gettext.h \
+ expand.h built-in.i extract-imsyms.sh
+
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
--- orig/libguile/boolean.c
+++ mod/libguile/boolean.c
@@ -24,13 +24,14 @@
#include "libguile/boolean.h"
#include "libguile/lang.h"
#include "libguile/tags.h"
+#include "libguile/imsyms.h"
-
-SCM_DEFINE (scm_not, "not", 1, 0, 0,
- (SCM x),
- "Return @code{#t} iff @var{x} is @code{#f}, else return
@code{#f}.")
+SCM_DEFINE_INLINABLE (scm_not, "not", scm_imsym_atnot, 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is @code{#f}, "
+ "else return @code{#f}.")
#define FUNC_NAME s_scm_not
{
return scm_from_bool (scm_is_false (x) || SCM_NILP (x));
--- orig/libguile/eq.c
+++ mod/libguile/eq.c
@@ -36,6 +36,7 @@
#include "libguile/validate.h"
#include "libguile/eq.h"
+#include "libguile/imsyms.h"
#ifdef HAVE_STRING_H
@@ -43,7 +44,7 @@
#endif
-SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
+SCM_DEFINE_INLINABLE (scm_eq_p, "eq?", scm_imsym_ateqp, 2, 0, 0,
(SCM x, SCM y),
"Return @code{#t} if @var{x} and @var{y} are the same object,\n"
"except for numbers and characters. For example,\n"
--- orig/libguile/eval.c
+++ mod/libguile/eval.c
@@ -98,9 +98,15 @@
static SCM unmemoize_exprs (SCM expr, SCM env);
static SCM canonicalize_define (SCM expr);
static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
-static SCM unmemoize_builtin_macro (SCM expr, SCM env);
static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
+typedef SCM (* scm_t_unmemoizer) (const SCM expr, const SCM env);
+
+static scm_t_unmemoizer unmemoizer_table[];
+#define unmemoize_builtin_macro(_expr, _env) \
+ (unmemoizer_table[(ISYMNUM (SCM_CAR (_expr)))] ((_expr), (_env)))
+
+
/* {Syntax Errors}
@@ -402,36 +408,19 @@
#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
-/* This table must agree with the list of SCM_IM_ constants in tags.h */
+/* This table must agree with the list of `scm_imsym_' constants
+ defined in `imsyms.h'. */
static const char *const isymnames[] =
-{
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden",
- "address@hidden"
-};
+ {
+#define EXTRACT_BUILT_IN_MACRO_NAMES
+#include "built-in-expand.h"
+#include "built-in.i"
+#undef EXTRACT_BUILT_IN_MACRO_NAMES
+ };
+
+
+#include "imsyms.h"
+
void
scm_i_print_isym (SCM isym, SCM port)
@@ -634,8 +623,8 @@
* body) into its internal form. The internal form of a body (<expr> ...) is
* just the body itself, but prefixed with an ISYM that denotes to what kind
* of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
- * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
- * SCM_IM_LET, etc.
+ * starts with scm_imsym_lambda, for example, a body of a let starts with
+ * scm_imsym_let, etc.
*
* It is assumed that the calling expression has already made sure that the
* body is a proper list. */
@@ -882,7 +871,7 @@
res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
if (scm_ilength (res) <= 0)
- res = scm_list_2 (SCM_IM_BEGIN, res);
+ res = scm_list_2 (scm_imsym_begin, res);
/* njrev: Several queries here: (1) I don't see how it can be
correct that the SCM_SETCAR 2 lines below this comment needs
@@ -923,7 +912,7 @@
}
else
{
- SCM_SETCAR (expr, SCM_IM_AND);
+ SCM_SETCAR (expr, scm_imsym_and);
return expr;
}
}
@@ -947,7 +936,7 @@
* empty clause is OK and where it is not. */
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- SCM_SETCAR (expr, SCM_IM_BEGIN);
+ SCM_SETCAR (expr, scm_imsym_begin);
return expr;
}
@@ -1008,7 +997,7 @@
/* build the new clause */
if (scm_is_eq (labels, scm_sym_else))
- SCM_SETCAR (clause, SCM_IM_ELSE);
+ SCM_SETCAR (clause, scm_imsym_else);
clauses = SCM_CDR (clauses);
}
@@ -1021,7 +1010,7 @@
s_duplicate_case_label, label, expr);
}
- SCM_SETCAR (expr, SCM_IM_CASE);
+ SCM_SETCAR (expr, scm_imsym_case);
return expr;
}
@@ -1041,7 +1030,7 @@
const SCM exprs = SCM_CDR (clause);
const SCM um_exprs = unmemoize_exprs (exprs, env);
- const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE))
+ const SCM um_labels = (scm_is_eq (labels, scm_imsym_else))
? scm_sym_else
: scm_i_finite_list_copy (labels);
const SCM um_clause = scm_cons (um_labels, um_exprs);
@@ -1089,7 +1078,7 @@
s_bad_cond_clause, clause, expr);
ASSERT_SYNTAX_2 (last_clause_p,
s_misplaced_else_clause, clause, expr);
- SCM_SETCAR (clause, SCM_IM_ELSE);
+ SCM_SETCAR (clause, scm_imsym_else);
}
else if (length >= 2
&& scm_is_eq (SCM_CADR (clause), scm_sym_arrow)
@@ -1097,7 +1086,7 @@
{
ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
- SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
+ SCM_SETCAR (SCM_CDR (clause), scm_imsym_arrow);
}
/* SRFI 61 extended cond */
else if (length >= 3
@@ -1106,11 +1095,11 @@
{
ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr);
ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr);
- SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW);
+ SCM_SETCAR (SCM_CDDR (clause), scm_imsym_arrow);
}
}
- SCM_SETCAR (expr, SCM_IM_COND);
+ SCM_SETCAR (expr, scm_imsym_cond);
return expr;
}
@@ -1131,13 +1120,13 @@
SCM um_sequence;
SCM um_clause;
- if (scm_is_eq (test, SCM_IM_ELSE))
+ if (scm_is_eq (test, scm_imsym_else))
um_test = scm_sym_else;
else
um_test = unmemoize_expression (test, env);
if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence),
- SCM_IM_ARROW))
+ scm_imsym_arrow))
{
const SCM target = SCM_CADR (sequence);
const SCM um_target = unmemoize_expression (target, env);
@@ -1278,7 +1267,7 @@
scm_m_delay (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
- SCM_SETCAR (new_expr, SCM_IM_DELAY);
+ SCM_SETCAR (new_expr, scm_imsym_delay);
return new_expr;
}
@@ -1363,7 +1352,7 @@
commands = SCM_CDR (cddr_expr);
tail = scm_cons2 (exit_clause, commands, step_forms);
tail = scm_cons2 (init_forms, variables, tail);
- SCM_SETCAR (expr, SCM_IM_DO);
+ SCM_SETCAR (expr, scm_imsym_do);
SCM_SETCDR (expr, tail);
return expr;
}
@@ -1415,7 +1404,7 @@
const SCM cdr_expr = SCM_CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
- SCM_SETCAR (expr, SCM_IM_IF);
+ SCM_SETCAR (expr, scm_imsym_if);
return expr;
}
@@ -1511,9 +1500,9 @@
cddr_expr = SCM_CDR (cdr_expr);
documentation = (length >= 3 && scm_is_string (SCM_CAR (cddr_expr)));
body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
- new_body = m_body (SCM_IM_LAMBDA, body);
+ new_body = m_body (scm_imsym_lambda, body);
- SCM_SETCAR (expr, SCM_IM_LAMBDA);
+ SCM_SETCAR (expr, scm_imsym_lambda);
if (documentation)
SCM_SETCDR (cddr_expr, new_body);
else
@@ -1614,15 +1603,15 @@
{
const SCM let_body = SCM_CDR (cddr_expr);
- const SCM lambda_body = m_body (SCM_IM_LET, let_body);
+ const SCM lambda_body = m_body (scm_imsym_let, let_body);
const SCM lambda_tail = scm_cons (variables, lambda_body);
const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda,
lambda_tail);
const SCM rvar = scm_list_1 (name);
const SCM init = scm_list_1 (lambda_form);
- const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
+ const SCM body = m_body (scm_imsym_let, scm_list_1 (name));
const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
- const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
+ const SCM letrec_form = scm_cons_source (expr, scm_imsym_letrec,
letrec_tail);
return scm_cons_source (expr, letrec_form, inits);
}
}
@@ -1650,7 +1639,7 @@
if (scm_is_null (bindings) || scm_is_null (SCM_CDR (bindings)))
{
/* Special case: no bindings or single binding => let* is faster. */
- const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
+ const SCM body = m_body (scm_imsym_let, SCM_CDR (cdr_expr));
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
}
else
@@ -1661,9 +1650,9 @@
transform_bindings (bindings, expr, &rvariables, &inits);
{
- const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
+ const SCM new_body = m_body (scm_imsym_let, SCM_CDR (cdr_expr));
const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
- SCM_SETCAR (expr, SCM_IM_LET);
+ SCM_SETCAR (expr, scm_imsym_let);
SCM_SETCDR (expr, new_tail);
return expr;
}
@@ -1716,7 +1705,7 @@
if (scm_is_null (bindings))
{
/* no bindings, let* is executed faster */
- SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ SCM body = m_body (scm_imsym_letrec, SCM_CDR (cdr_expr));
return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
}
else
@@ -1727,8 +1716,8 @@
check_bindings (bindings, expr);
transform_bindings (bindings, expr, &rvariables, &inits);
- new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
+ new_body = m_body (scm_imsym_letrec, SCM_CDR (cdr_expr));
+ return scm_cons2 (scm_imsym_letrec, rvariables, scm_cons (inits,
new_body));
}
}
@@ -1790,8 +1779,8 @@
binding_idx = cdr_binding_idx; /* continue with P3 */
}
- new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
- SCM_SETCAR (expr, SCM_IM_LETSTAR);
+ new_body = m_body (scm_imsym_letstar, SCM_CDR (cdr_expr));
+ SCM_SETCAR (expr, scm_imsym_letstar);
/* the bindings have been changed in place */
SCM_SETCDR (cdr_expr, new_body);
return expr;
@@ -1842,7 +1831,7 @@
}
else
{
- SCM_SETCAR (expr, SCM_IM_OR);
+ SCM_SETCAR (expr, scm_imsym_or);
return expr;
}
}
@@ -1936,7 +1925,7 @@
if (is_self_quoting_p (quotee))
return quotee;
- SCM_SETCAR (expr, SCM_IM_QUOTE);
+ SCM_SETCAR (expr, scm_imsym_quote);
SCM_SETCDR (expr, quotee);
return expr;
}
@@ -1971,7 +1960,7 @@
if (SCM_UNBNDP (new_variable))
new_variable = variable;
- SCM_SETCAR (expr, SCM_IM_SET_X);
+ SCM_SETCAR (expr, scm_imsym_set_x);
SCM_SETCAR (cdr_expr, new_variable);
return expr;
}
@@ -1982,7 +1971,79 @@
return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
}
+static const char s_null_p[] = "null?";
+SCM_GLOBAL_SYMBOL (scm_sym_null_p, s_null_p);
+
+static SCM
+unmemoize_atnullp (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_null_p, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+static const char s_pair_p[] = "pair?";
+SCM_GLOBAL_SYMBOL (scm_sym_pair_p, s_pair_p);
+
+static SCM
+unmemoize_atpairp (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_pair_p, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+static const char s_list_p[] = "list?";
+SCM_GLOBAL_SYMBOL (scm_sym_list_p, s_list_p);
+
+static SCM
+unmemoize_atlistp (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_list_p, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+static const char s_car[] = "car";
+SCM_GLOBAL_SYMBOL (scm_sym_car, s_car);
+
+static SCM
+unmemoize_atcar (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_car, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+static const char s_cdr[] = "cdr";
+SCM_GLOBAL_SYMBOL (scm_sym_cdr, s_cdr);
+
+static SCM
+unmemoize_atcdr (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_cdr, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+static const char s_cons[] = "cons";
+SCM_GLOBAL_SYMBOL (scm_sym_cons, s_cons);
+
+static SCM
+unmemoize_atcons (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_cons, unmemoize_exprs (SCM_CDR (expr), env));
+}
+static const char s_not[] = "not";
+SCM_GLOBAL_SYMBOL (scm_sym_not, s_not);
+
+static SCM
+unmemoize_atnot (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_not, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+static const char s_eq_p[] = "eq?";
+SCM_GLOBAL_SYMBOL (scm_sym_eq_p, s_eq_p);
+
+static SCM
+unmemoize_ateqp (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_eq_p, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
/* Start of the memoizers for non-R5RS builtin macros. */
@@ -1997,7 +2058,7 @@
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
- SCM_SETCAR (expr, SCM_IM_APPLY);
+ SCM_SETCAR (expr, scm_imsym_apply);
return expr;
}
@@ -2057,7 +2118,7 @@
SCM_SETCAR (variable_idx, new_variable);
}
- SCM_SETCAR (expr, SCM_IM_BIND);
+ SCM_SETCAR (expr, scm_imsym_bind);
SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
return expr;
}
@@ -2073,7 +2134,7 @@
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
- SCM_SETCAR (expr, SCM_IM_CONT);
+ SCM_SETCAR (expr, scm_imsym_cont);
return expr;
}
@@ -2094,7 +2155,7 @@
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
- SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
+ SCM_SETCAR (expr, scm_imsym_call_with_values);
return expr;
}
@@ -2122,7 +2183,7 @@
scm_m_future (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
- SCM_SETCAR (new_expr, SCM_IM_FUTURE);
+ SCM_SETCAR (new_expr, scm_imsym_future);
return new_expr;
}
@@ -2161,7 +2222,7 @@
variable and we memoize to (set! <atom> ...).
*/
exp_target = macroexp (target, env);
- if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN)
+ if (scm_is_eq (SCM_CAR (exp_target), scm_imsym_begin)
&& !scm_is_null (SCM_CDR (exp_target))
&& scm_is_null (SCM_CDDR (exp_target)))
{
@@ -2169,7 +2230,7 @@
ASSERT_SYNTAX_2 (scm_is_symbol (exp_target)
|| SCM_VARIABLEP (exp_target),
s_bad_variable, exp_target, expr);
- return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
+ return scm_cons (scm_imsym_set_x, scm_cons (exp_target,
SCM_CDR (cdr_expr)));
}
else
@@ -2208,7 +2269,7 @@
slot_nr = SCM_CADR (cdr_expr);
ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
- SCM_SETCAR (expr, SCM_IM_SLOT_REF);
+ SCM_SETCAR (expr, scm_imsym_slot_ref);
SCM_SETCDR (cdr_expr, slot_nr);
return expr;
}
@@ -2241,7 +2302,7 @@
slot_nr = SCM_CADR (cdr_expr);
ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
- SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
+ SCM_SETCAR (expr, scm_imsym_slot_set_x);
return expr;
}
@@ -2275,7 +2336,7 @@
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
- SCM_SETCAR (expr, SCM_IM_NIL_COND);
+ SCM_SETCAR (expr, scm_imsym_nil_cond);
return expr;
}
@@ -2325,7 +2386,7 @@
/* Since the location does not contain a macro, the form is a procedure
* application. Replace address@hidden' by address@hidden' and
transform the expression
* including the `transformer-macro'. */
- SCM_SETCAR (expr, SCM_IM_APPLY);
+ SCM_SETCAR (expr, scm_imsym_apply);
return expr;
}
else
@@ -2341,86 +2402,14 @@
#endif /* SCM_ENABLE_ELISP */
+static scm_t_unmemoizer unmemoizer_table[] =
+ {
+#define EXTRACT_BUILT_IN_MACRO_UNMEMOIZERS
+#include "built-in-expand.h"
+#include "built-in.i"
+#undef EXTRACT_BUILT_IN_MACRO_UNMEMOIZERS
+ };
-static SCM
-unmemoize_builtin_macro (const SCM expr, const SCM env)
-{
- switch (ISYMNUM (SCM_CAR (expr)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- return unmemoize_and (expr, env);
-
- case (ISYMNUM (SCM_IM_BEGIN)):
- return unmemoize_begin (expr, env);
-
- case (ISYMNUM (SCM_IM_CASE)):
- return unmemoize_case (expr, env);
-
- case (ISYMNUM (SCM_IM_COND)):
- return unmemoize_cond (expr, env);
-
- case (ISYMNUM (SCM_IM_DELAY)):
- return unmemoize_delay (expr, env);
-
- case (ISYMNUM (SCM_IM_DO)):
- return unmemoize_do (expr, env);
-
- case (ISYMNUM (SCM_IM_IF)):
- return unmemoize_if (expr, env);
-
- case (ISYMNUM (SCM_IM_LAMBDA)):
- return unmemoize_lambda (expr, env);
-
- case (ISYMNUM (SCM_IM_LET)):
- return unmemoize_let (expr, env);
-
- case (ISYMNUM (SCM_IM_LETREC)):
- return unmemoize_letrec (expr, env);
-
- case (ISYMNUM (SCM_IM_LETSTAR)):
- return unmemoize_letstar (expr, env);
-
- case (ISYMNUM (SCM_IM_OR)):
- return unmemoize_or (expr, env);
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- return unmemoize_quote (expr, env);
-
- case (ISYMNUM (SCM_IM_SET_X)):
- return unmemoize_set_x (expr, env);
-
- case (ISYMNUM (SCM_IM_APPLY)):
- return unmemoize_apply (expr, env);
-
- case (ISYMNUM (SCM_IM_BIND)):
- return unmemoize_exprs (expr, env); /* FIXME */
-
- case (ISYMNUM (SCM_IM_CONT)):
- return unmemoize_atcall_cc (expr, env);
-
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- return unmemoize_at_call_with_values (expr, env);
-
-#if 0
- /* See futures.h for a comment why futures are not enabled.
- */
- case (ISYMNUM (SCM_IM_FUTURE)):
- return unmemoize_future (expr, env);
-#endif
-
- case (ISYMNUM (SCM_IM_SLOT_REF)):
- return unmemoize_atslot_ref (expr, env);
-
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
- return unmemoize_atslot_set_x (expr, env);
-
- case (ISYMNUM (SCM_IM_NIL_COND)):
- return unmemoize_exprs (expr, env); /* FIXME */
-
- default:
- return unmemoize_exprs (expr, env); /* FIXME */
- }
-}
/* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
@@ -2687,7 +2676,7 @@
* binding within the frame, and last? (which is extracted from the iloc using
* the macro SCM_ICDRP) indicates whether the binding forms the binding at the
* very end of the improper list of bindings. */
-SCM *
+static inline SCM *
scm_ilookup (SCM iloc, SCM env)
{
unsigned int frame_nr = SCM_IFRAME (iloc);
@@ -3067,7 +3056,10 @@
long scm_eval_stack;
scm_t_option scm_eval_opts[] = {
- { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine
words)." }
+ { SCM_OPTION_INTEGER, "stack", 22000,
+ "Size of thread stacks (in machine words)." },
+ { SCM_OPTION_BOOLEAN, "inline", 1,
+ "Inline calls to built-in procedures like `null?', `car', etc." }
};
scm_t_option scm_debug_opts[] = {
@@ -3193,6 +3185,9 @@
*/
+/* Whether inlining of built-in procedures is enabled. */
+#define SCM_INLINE_MODE_P (scm_eval_opts[1].val)
+
/* Update the toplevel environment frame ENV so that it refers to the
* current module. */
#define UPDATE_TOPLEVEL_ENV(env) \
@@ -3324,9 +3319,19 @@
SCM_TICK;
if (SCM_ISYMP (SCM_CAR (x)))
{
- switch (ISYMNUM (SCM_CAR (x)))
+#ifdef SCM_USE_DISPATCH_TABLES
+ static void *BUILT_IN_MACRO_DISPATCH_TABLE (builtin_dispatch)[] =
+ {
+#define EXTRACT_BUILT_IN_MACRO_DISPATCH_TABLE
+#include "built-in-expand.h"
+#include "built-in.i"
+#undef EXTRACT_BUILT_IN_MACRO_DISPATCH_TABLE
+ };
+#endif
+
+ BUILT_IN_MACRO_DISPATCH (builtin_dispatch, SCM_CAR (x))
{
- case (ISYMNUM (SCM_IM_AND)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, and):
x = SCM_CDR (x);
while (!scm_is_null (SCM_CDR (x)))
{
@@ -3339,7 +3344,7 @@
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case (ISYMNUM (SCM_IM_BEGIN)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, begin):
x = SCM_CDR (x);
if (scm_is_null (x))
RETURN (SCM_UNSPECIFIED);
@@ -3409,7 +3414,7 @@
}
- case (ISYMNUM (SCM_IM_CASE)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, case):
x = SCM_CDR (x);
{
const SCM key = EVALCAR (x, env);
@@ -3418,7 +3423,7 @@
{
const SCM clause = SCM_CAR (x);
SCM labels = SCM_CAR (clause);
- if (scm_is_eq (labels, SCM_IM_ELSE))
+ if (scm_is_eq (labels, scm_imsym_else))
{
x = SCM_CDR (clause);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
@@ -3442,12 +3447,12 @@
RETURN (SCM_UNSPECIFIED);
- case (ISYMNUM (SCM_IM_COND)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, cond):
x = SCM_CDR (x);
while (!scm_is_null (x))
{
const SCM clause = SCM_CAR (x);
- if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
+ if (scm_is_eq (SCM_CAR (clause), scm_imsym_else))
{
x = SCM_CDR (clause);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
@@ -3459,7 +3464,7 @@
/* SRFI 61 extended cond */
if (!scm_is_null (SCM_CDR (clause))
&& !scm_is_null (SCM_CDDR (clause))
- && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
+ && scm_is_eq (SCM_CADDR (clause), scm_imsym_arrow))
{
SCM xx, guard_result;
if (SCM_VALUESP (arg1))
@@ -3483,7 +3488,7 @@
x = SCM_CDR (clause);
if (scm_is_null (x))
RETURN (arg1);
- else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
+ else if (!scm_is_eq (SCM_CAR (x), scm_imsym_arrow))
{
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
@@ -3503,7 +3508,7 @@
RETURN (SCM_UNSPECIFIED);
- case (ISYMNUM (SCM_IM_DO)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, do):
x = SCM_CDR (x);
{
/* Compute the initialization values and the initial environment.
*/
@@ -3574,7 +3579,7 @@
goto nontoplevel_begin;
- case (ISYMNUM (SCM_IM_IF)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, if):
x = SCM_CDR (x);
{
SCM test_result = EVALCAR (x, env);
@@ -3590,7 +3595,7 @@
goto carloop;
- case (ISYMNUM (SCM_IM_LET)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, let):
x = SCM_CDR (x);
{
SCM init_forms = SCM_CADR (x);
@@ -3608,7 +3613,7 @@
goto nontoplevel_begin;
- case (ISYMNUM (SCM_IM_LETREC)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, letrec):
x = SCM_CDR (x);
env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
x = SCM_CDR (x);
@@ -3624,7 +3629,7 @@
goto nontoplevel_begin;
- case (ISYMNUM (SCM_IM_LETSTAR)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, letstar):
x = SCM_CDR (x);
{
SCM bindings = SCM_CAR (x);
@@ -3645,7 +3650,7 @@
goto nontoplevel_begin;
- case (ISYMNUM (SCM_IM_OR)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, or):
x = SCM_CDR (x);
while (!scm_is_null (SCM_CDR (x)))
{
@@ -3659,15 +3664,15 @@
goto carloop;
- case (ISYMNUM (SCM_IM_LAMBDA)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, lambda):
RETURN (scm_closure (SCM_CDR (x), env));
- case (ISYMNUM (SCM_IM_QUOTE)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, quote):
RETURN (SCM_CDR (x));
- case (ISYMNUM (SCM_IM_SET_X)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, set_x):
x = SCM_CDR (x);
{
SCM *location;
@@ -3689,7 +3694,7 @@
RETURN (SCM_UNSPECIFIED);
- case (ISYMNUM (SCM_IM_APPLY)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, apply):
/* Evaluate the procedure to be applied. */
x = SCM_CDR (x);
proc = EVALCAR (x, env);
@@ -3740,7 +3745,7 @@
}
- case (ISYMNUM (SCM_IM_CONT)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, cont):
{
int first;
SCM val = scm_make_continuation (&first);
@@ -3759,19 +3764,19 @@
}
- case (ISYMNUM (SCM_IM_DELAY)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, delay):
RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
#if 0
/* See futures.h for a comment why futures are not enabled.
*/
- case (ISYMNUM (SCM_IM_FUTURE)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, future):
RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
#endif
- /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
+ /* PLACEHOLDER for case (ISYMNUM (scm_imsym_dispatch)): The following
code (type_dispatch) is intended to be the tail of the case
- clause for the internal macro SCM_IM_DISPATCH. Please don't
+ clause for the internal macro scm_imsym_dispatch. Please don't
remove it from this location without discussing it with Mikael
<address@hidden> */
@@ -3904,7 +3909,7 @@
}
- case (ISYMNUM (SCM_IM_SLOT_REF)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, slot_ref):
x = SCM_CDR (x);
{
SCM instance = EVALCAR (x, env);
@@ -3913,7 +3918,7 @@
}
- case (ISYMNUM (SCM_IM_SLOT_SET_X)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, slot_set_x):
x = SCM_CDR (x);
{
SCM instance = EVALCAR (x, env);
@@ -3925,8 +3930,8 @@
#if SCM_ENABLE_ELISP
-
- case (ISYMNUM (SCM_IM_NIL_COND)):
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, nil_cond):
{
SCM test_form = SCM_CDR (x);
x = SCM_CDR (test_form);
@@ -3954,7 +3959,7 @@
#endif /* SCM_ENABLE_ELISP */
- case (ISYMNUM (SCM_IM_BIND)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, bind):
{
SCM vars, exps, vals;
@@ -3986,7 +3991,7 @@
}
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, call_with_values):
{
SCM producer;
@@ -4009,9 +4014,74 @@
goto apply_proc;
}
+ /* The inlinables. */
- default:
- break;
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atnullp):
+ {
+ SCM operand = EVALCAR (SCM_CDR (x), env);
+ RETURN (scm_from_bool (SCM_NULL_OR_NIL_P (operand)));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atpairp):
+ {
+ SCM operand = EVALCAR (SCM_CDR (x), env);
+ RETURN (scm_from_bool (scm_is_pair (operand)));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atlistp):
+ {
+ SCM operand = EVALCAR (SCM_CDR (x), env);
+ RETURN (scm_from_bool (scm_ilength (operand) >= 0));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atcar):
+ {
+ SCM operand = EVALCAR (SCM_CDR (x), env);
+ if (!scm_is_pair (operand))
+ scm_wrong_type_arg ("car", 1, operand);
+ RETURN (SCM_CAR (operand));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atcdr):
+ {
+ SCM operand = EVALCAR (SCM_CDR (x), env);
+ if (!scm_is_pair (operand))
+ scm_wrong_type_arg ("cdr", 1, operand);
+ RETURN (SCM_CDR (operand));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atcons):
+ {
+ SCM op1, op2;
+ op1 = EVALCAR (SCM_CDR (x), env);
+ op2 = EVALCAR (SCM_CDDR (x), env);
+ RETURN (scm_cell (SCM_UNPACK (op1), SCM_UNPACK (op2)));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, atnot):
+ {
+ SCM operand = EVALCAR (SCM_CDR (x), env);
+ RETURN (scm_from_bool (scm_is_false (operand)
+ || SCM_NILP (operand)));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, ateqp):
+ {
+ SCM op1, op2;
+ op1 = EVALCAR (SCM_CDR (x), env);
+ op2 = EVALCAR (SCM_CDDR (x), env);
+ RETURN (scm_from_bool (scm_is_eq (op1, op2)));
+ }
+
+ BUILT_IN_MACRO_CASE (builtin_dispatch, arrow):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, else):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, dispatch):
+ BUILT_IN_MACRO_CASE (builtin_dispatch, define):
+ /* Nothing to do. */
+ {
+ /* XXX: Avoiding the ``label at end of compound statement'' error. */
+ (void)0;
+ }
}
}
else
@@ -4032,7 +4102,56 @@
/* we have lost the race, start again. */
goto dispatch;
}
+
proc = *location;
+
+ if ((SCM_INLINE_MODE_P) && (SCM_VARIABLEP (SCM_CAR (x))))
+ {
+ /* Only procedures from the top-level are subject to
+ inlining. */
+ long subr_type = SCM_TYP7 (proc);
+
+ switch (subr_type)
+ {
+ case scm_tcs_subrs:
+ if (SCM_SUBR_INLINABLEP (proc))
+ {
+ /* If PROC is inlinable, then inline it by replacing
+ it with the corresponding immediate symbol and
+ jump back to `dispatch'. */
+#if 0
+ printf ("inlining call to `%s'\n",
+ scm_i_symbol_chars (SCM_SNAME (proc)));
+#endif
+
+ /* Check the number of args passed. */
+ switch (subr_type)
+ {
+ case scm_tc7_subr_0:
+ if (!scm_is_null (SCM_CDR (x)))
+ scm_wrong_num_args (proc);
+ break;
+ case scm_tc7_subr_1:
+ if ((scm_is_null (SCM_CDR (x)))
+ || (!scm_is_null (SCM_CDDR (x))))
+ scm_wrong_num_args (proc);
+ break;
+ case scm_tc7_subr_2:
+ if ((scm_is_null (SCM_CDR (x)))
+ || (scm_is_null (SCM_CDDR (x)))
+ || (!scm_is_null (SCM_CDDDR (x))))
+ scm_wrong_num_args (proc);
+ break;
+ default:
+ /* Unsupported argument count. */
+ abort ();
+ }
+
+ SCM_SETCAR (x, SCM_INLINABLE_SUBR_IMSYM (proc));
+ goto dispatch;
+ }
+ }
+ }
}
if (SCM_MACROP (proc))
@@ -4055,7 +4174,7 @@
case 3:
case 2:
if (!scm_is_pair (arg1))
- arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
+ arg1 = scm_list_2 (scm_imsym_begin, arg1);
assert (!scm_is_eq (x, SCM_CAR (arg1))
&& !scm_is_eq (x, SCM_CDR (arg1)));
@@ -4644,40 +4763,6 @@
-/* Simple procedure calls
- */
-
-SCM
-scm_call_0 (SCM proc)
-{
- return scm_apply (proc, SCM_EOL, SCM_EOL);
-}
-
-SCM
-scm_call_1 (SCM proc, SCM arg1)
-{
- return scm_apply (proc, arg1, scm_listofnull);
-}
-
-SCM
-scm_call_2 (SCM proc, SCM arg1, SCM arg2)
-{
- return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
-}
-
-SCM
-scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
-{
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
-}
-
-SCM
-scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
-{
- return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
- scm_cons (arg4, scm_listofnull)));
-}
-
/* Simple procedure applies
*/
--- orig/libguile/eval.h
+++ mod/libguile/eval.h
@@ -3,7 +3,7 @@
#ifndef SCM_EVAL_H
#define SCM_EVAL_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2006
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -27,6 +27,13 @@
#include "libguile/struct.h"
+/* Headers needed by the inline functions below. */
+#include "libguile/debug.h"
+#include "libguile/gc.h"
+#include "libguile/pairs.h"
+
+
+
/* {Options}
@@ -35,7 +42,7 @@
SCM_API scm_t_option scm_eval_opts[];
#define SCM_EVAL_STACK scm_eval_opts[0].val
-#define SCM_N_EVAL_OPTIONS 1
+#define SCM_N_EVAL_OPTIONS 2
SCM_API long scm_eval_stack;
@@ -123,9 +130,9 @@
SCM_API SCM scm_sym_set_x;
SCM_API SCM scm_sym_args;
+
-SCM_API SCM * scm_ilookup (SCM iloc, SCM env);
SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
SCM_API SCM scm_eval_car (SCM pair, SCM env);
SCM_API SCM scm_eval_body (SCM code, SCM env);
@@ -162,11 +169,6 @@
SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env);
SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
SCM_API int scm_badargsp (SCM formals, SCM args);
-SCM_API SCM scm_call_0 (SCM proc);
-SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
-SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
-SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
-SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
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);
@@ -199,7 +201,62 @@
SCM_API SCM scm_i_unmemocopy_body (SCM forms, SCM env);
SCM_API void scm_init_eval (void);
+
+/* Simple procedure calls. */
+
+static SCM_C_INLINE SCM
+scm_call_0 (SCM _proc)
+{
+ return (scm_debug_mode_p
+ ? (scm_apply ((_proc), SCM_EOL, SCM_EOL))
+ : ((SCM_CELL_TYPE (_proc) == scm_tc7_subr_0)
+ ? (SCM_SUBRF (_proc) ())
+ : scm_apply ((_proc), SCM_EOL, SCM_EOL)));
+}
+
+static SCM_C_INLINE SCM
+scm_call_1 (SCM _proc, SCM _arg)
+{
+ return (scm_debug_mode_p
+ ? (scm_apply ((_proc), scm_cons ((_arg), SCM_EOL), SCM_EOL))
+ : ((SCM_CELL_TYPE (_proc) == scm_tc7_subr_1)
+ ? (SCM_SUBRF (_proc) (_arg))
+ : scm_apply ((_proc), scm_cons ((_arg), SCM_EOL), SCM_EOL)));
+}
+
+static SCM_C_INLINE SCM
+scm_call_2 (SCM _proc, SCM _a1, SCM _a2)
+{
+ return (scm_debug_mode_p
+ ? (scm_apply ((_proc), (_a1), scm_cons ((_a2), scm_listofnull)))
+ : ((SCM_CELL_TYPE (_proc) == scm_tc7_subr_2)
+ ? (SCM_SUBRF (_proc) ((_a1), (_a2)))
+ : scm_apply ((_proc), (_a1), scm_cons ((_a2), scm_listofnull))));
+}
+
+static SCM_C_INLINE SCM
+scm_call_3 (SCM _proc, SCM _a1, SCM _a2, SCM _a3)
+{
+ return (scm_debug_mode_p
+ ? (scm_apply ((_proc), (_a1),
+ scm_cons2 ((_a2), (_a3), scm_listofnull)))
+ : ((SCM_CELL_TYPE (_proc) == scm_tc7_subr_3)
+ ? (SCM_SUBRF (_proc) ((_a1), (_a2), (_a3)))
+ : scm_apply ((_proc), (_a1),
+ scm_cons2 ((_a2), (_a3), scm_listofnull))));
+}
+
+static SCM_C_INLINE SCM
+scm_call_4 (SCM _proc, SCM _a1, SCM _a2, SCM _a3, SCM _a4)
+{
+ return (scm_apply ((_proc), (_a1),
+ scm_cons2 ((_a2), (_a3),
+ scm_cons ((_a4), scm_listofnull))));
+}
+
+
+
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_API SCM scm_m_undefine (SCM x, SCM env);
--- orig/libguile/goops.c
+++ mod/libguile/goops.c
@@ -52,6 +52,11 @@
#include "libguile/validate.h"
#include "libguile/goops.h"
+
+/* Import definitions of the evaluator's immediate symbols. */
+#include "imsyms.h"
+
+
#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
#define DEFVAR(v, val) \
@@ -1152,7 +1157,7 @@
"Internal GOOPS magic---don't use this function!")
#define FUNC_NAME s_scm_sys_tag_body
{
- return scm_cons (SCM_IM_LAMBDA, body);
+ return scm_cons (scm_imsym_lambda, body);
}
#undef FUNC_NAME
@@ -1762,7 +1767,7 @@
SCM
scm_make_method_cache (SCM gf)
{
- return scm_list_5 (SCM_IM_DISPATCH,
+ return scm_list_5 (scm_imsym_dispatch,
scm_sym_args,
scm_from_int (1),
scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
--- orig/libguile/gsubr.c
+++ mod/libguile/gsubr.c
@@ -38,74 +38,120 @@
SCM scm_f_gsubr_apply;
static SCM
-create_gsubr (int define, const char *name,
- int req, int opt, int rst, SCM (*fcn)())
+create_gsubr (int define, int inlinable, const char *name,
+ int req, int opt, int rst, SCM (*fcn)(), SCM imsym)
{
SCM subr;
- switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
+ if (inlinable)
{
- case SCM_GSUBR_MAKTYPE(0, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(1, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(0, 1, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(1, 1, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(2, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(3, 0, 0):
- subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(0, 0, 1):
- subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
- goto create_subr;
- case SCM_GSUBR_MAKTYPE(2, 0, 1):
- subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
- create_subr:
- if (define)
- scm_define (SCM_SUBR_ENTRY(subr).name, subr);
- return subr;
- default:
- {
- SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
- SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
- SCM sym = SCM_SUBR_ENTRY(subr).name;
- if (SCM_GSUBR_MAX < req + opt + rst)
+ if ((opt != 0) || (rst != 0))
+ /* The common inlinables don't take optional/rest arguments. */
+ abort ();
+
+ switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
+ {
+ case SCM_GSUBR_MAKTYPE(0, 0, 0):
+ subr = scm_c_make_inlinable_subr (name, scm_tc7_subr_0,
+ fcn, imsym);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 0, 0):
+ subr = scm_c_make_inlinable_subr (name, scm_tc7_subr_1,
+ fcn, imsym);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 0):
+ subr = scm_c_make_inlinable_subr (name, scm_tc7_subr_2,
+ fcn, imsym);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(3, 0, 0):
+ subr = scm_c_make_inlinable_subr (name, scm_tc7_subr_3,
+ fcn, imsym);
+ goto create_subr;
+
+ default:
+ abort ();
+ }
+ }
+ else
+ {
+ switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
+ {
+ case SCM_GSUBR_MAKTYPE(0, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(0, 1, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 1, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(3, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(0, 0, 1):
+ subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 1):
+ subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
+ create_subr:
+ if (define)
+ scm_define (SCM_SUBR_ENTRY(subr).name, subr);
+ return subr;
+ default:
{
- fprintf (stderr,
- "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
- req + opt + rst, name);
- exit (1);
+ SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
+ SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
+ SCM sym = SCM_SUBR_ENTRY(subr).name;
+ if (SCM_GSUBR_MAX < req + opt + rst)
+ {
+ fprintf (stderr,
+ "ERROR in scm_c_make_gsubr: too many args (%d) to
%s\n",
+ req + opt + rst, name);
+ exit (1);
+ }
+ SCM_SET_GSUBR_PROC (cclo, subr);
+ SCM_SET_GSUBR_TYPE (cclo,
+ scm_from_int (SCM_GSUBR_MAKTYPE (req, opt,
rst)));
+ if (SCM_REC_PROCNAMES_P)
+ scm_set_procedure_property_x (cclo, scm_sym_name, sym);
+ if (define)
+ scm_define (sym, cclo);
+ return cclo;
}
- SCM_SET_GSUBR_PROC (cclo, subr);
- SCM_SET_GSUBR_TYPE (cclo,
- scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst)));
- if (SCM_REC_PROCNAMES_P)
- scm_set_procedure_property_x (cclo, scm_sym_name, sym);
- if (define)
- scm_define (sym, cclo);
- return cclo;
- }
+ }
}
}
SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
- return create_gsubr (0, name, req, opt, rst, fcn);
+ return create_gsubr (0, 0, name, req, opt, rst, fcn, SCM_BOOL_F);
}
SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
- return create_gsubr (1, name, req, opt, rst, fcn);
+ return create_gsubr (1, 0, name, req, opt, rst, fcn, SCM_BOOL_F);
+}
+
+SCM
+scm_c_make_inlinable_gsubr (const char *name, int req, int opt, int rst,
+ SCM (*fcn) (), SCM imsym)
+{
+ return create_gsubr (1, 1, name, req, opt, rst, fcn, imsym);
+}
+
+SCM
+scm_c_define_inlinable_gsubr (const char *name, int req, int opt, int rst,
+ SCM (*fcn) (), SCM imsym)
+{
+ return create_gsubr (1, 1, name, req, opt, rst, fcn, imsym);
}
static SCM
--- orig/libguile/gsubr.h
+++ mod/libguile/gsubr.h
@@ -41,6 +41,10 @@
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, SCM (*fcn) ());
+SCM_API SCM scm_c_make_inlinable_gsubr (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn) (),
+ SCM imsym);
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
int req, int opt, int rst,
SCM (*fcn) (), SCM *gf);
@@ -50,6 +54,11 @@
int req, int opt, int rst,
SCM (*fcn) (), SCM *gf);
+SCM_API SCM scm_c_define_inlinable_gsubr (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn) (),
+ SCM imsym);
+
SCM_API SCM scm_gsubr_apply (SCM args);
SCM_API void scm_init_gsubr (void);
--- orig/libguile/list.c
+++ mod/libguile/list.c
@@ -26,6 +26,8 @@
#include "libguile/list.h"
#include "libguile/eval.h"
+#include "libguile/imsyms.h"
+
#include <stdarg.h>
@@ -150,9 +152,10 @@
/* general questions about lists --- null?, list?, length, etc. */
-SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
+SCM_DEFINE_INLINABLE (scm_null_p, "null?", scm_imsym_atnullp, 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is the empty list, "
+ "else @code{#f}.")
#define FUNC_NAME s_scm_null_p
{
return scm_from_bool (SCM_NULL_OR_NIL_P (x));
@@ -160,9 +163,10 @@
#undef FUNC_NAME
-SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
+SCM_DEFINE_INLINABLE (scm_list_p, "list?", scm_imsym_atlistp, 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a proper list, "
+ "else @code{#f}.")
#define FUNC_NAME s_scm_list_p
{
return scm_from_bool (scm_ilength (x) >= 0);
--- orig/libguile/load.c
+++ mod/libguile/load.c
@@ -55,6 +55,7 @@
#define R_OK 4
#endif
+
/* Loading a file, given an absolute filename. */
--- orig/libguile/pairs.c
+++ mod/libguile/pairs.c
@@ -22,6 +22,8 @@
#include "libguile/validate.h"
#include "libguile/pairs.h"
+#include "libguile/imsyms.h"
+
@@ -49,11 +51,12 @@
#endif
-SCM_DEFINE (scm_cons, "cons", 2, 0, 0,
- (SCM x, SCM y),
- "Return a newly allocated pair whose car is @var{x} and whose\n"
- "cdr is @var{y}. The pair is guaranteed to be different (in the\n"
- "sense of @code{eq?}) from every previously existing object.")
+SCM_DEFINE_INLINABLE (scm_cons, "cons", scm_imsym_atcons, 2, 0, 0,
+ (SCM x, SCM y),
+ "Return a newly allocated pair whose car is @var{x} "
+ "and whose cdr is @var{y}. The pair is guaranteed "
+ "to be different (in the sense of @code{eq?}) from "
+ "every previously existing object.")
#define FUNC_NAME s_scm_cons
{
return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
@@ -68,31 +71,37 @@
}
-SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is a pair; otherwise return\n"
- "@code{#f}.")
+SCM_DEFINE_INLINABLE (scm_pair_p, "pair?", scm_imsym_atpairp, 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a pair; "
+ "otherwise return @code{#f}.")
#define FUNC_NAME s_scm_pair_p
{
return scm_from_bool (scm_is_pair (x));
}
#undef FUNC_NAME
-SCM
-scm_car (SCM pair)
+SCM_DEFINE_INLINABLE (scm_car, "car", scm_imsym_atcar, 1, 0, 0,
+ (SCM pair),
+ "Return the @code{car} of @var{pair}.")
+#define FUNC_NAME s_scm_car
{
if (!scm_is_pair (pair))
scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
return SCM_CAR (pair);
}
+#undef FUNC_NAME
-SCM
-scm_cdr (SCM pair)
+SCM_DEFINE_INLINABLE (scm_cdr, "cdr", scm_imsym_atcdr, 1, 0, 0,
+ (SCM pair),
+ "Return the @code{cdr} of @var{pair}.")
+#define FUNC_NAME s_scm_cdr
{
if (!scm_is_pair (pair))
scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
return SCM_CDR (pair);
}
+#undef FUNC_NAME
SCM
scm_i_chase_pairs (SCM tree, scm_t_uint32 pattern)
@@ -188,7 +197,9 @@
{
unsigned int subnr = 0;
- for (subnr = 0; cxrs[subnr].name; subnr++)
+ /* We start after CAR and CDR which are treated as inlinable primitive
+ procedures. */
+ for (subnr = 2; cxrs[subnr].name; subnr++)
{
SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
--- orig/libguile/procs.c
+++ mod/libguile/procs.c
@@ -66,12 +66,36 @@
scm_subr_table[entry].name = scm_from_locale_symbol (name);
scm_subr_table[entry].generic = 0;
scm_subr_table[entry].properties = SCM_EOL;
+
+ /* Information used by the inlinable mechanism. */
+ scm_subr_table[entry].inlinable = 0;
+ scm_subr_table[entry].inlined_builtin = SCM_UNSPECIFIED;
+
scm_subr_table_size++;
-
+
return z;
}
SCM
+scm_c_make_inlinable_subr (const char *name, long type,
+ SCM (*fcn) (), SCM imsym)
+{
+ register SCM subr;
+ register long entry;
+
+ if (!SCM_ISYMP (imsym))
+ scm_wrong_type_arg (__FUNCTION__, 4, imsym);
+
+ subr = scm_c_make_subr (name, type, fcn);
+
+ entry = SCM_SUBRNUM (subr);
+ scm_subr_table[entry].inlinable = 1;
+ scm_subr_table[entry].inlined_builtin = imsym;
+
+ return subr;
+}
+
+SCM
scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
{
SCM subr = scm_c_make_subr (name, type, fcn);
--- orig/libguile/procs.h
+++ mod/libguile/procs.h
@@ -38,6 +38,10 @@
* *generic == 0 until first method
*/
SCM properties; /* procedure properties */
+
+ int inlinable; /* non-zero if this is an inlinable */
+ SCM inlined_builtin; /* the immediate symbol of the corresponding
+ built-in that is inlined in `eval.c' */
} scm_t_subr_entry;
#define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8)
@@ -51,6 +55,9 @@
#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties)
#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic)
+#define SCM_SUBR_INLINABLEP(x) (SCM_SUBR_ENTRY (x).inlinable)
+#define SCM_INLINABLE_SUBR_IMSYM(x) (SCM_SUBR_ENTRY (x).inlined_builtin)
+
#define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8)
#define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo)
#define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x),
SCM_MAKE_CCLO_TAG(v)))
@@ -141,6 +148,9 @@
SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf);
+SCM_API SCM scm_c_make_inlinable_subr (const char *name, long type,
+ SCM (*fcn) (),
+ SCM imsym);
SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)());
SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
SCM (*fcn)(), SCM *gf);
--- orig/libguile/snarf.h
+++ mod/libguile/snarf.h
@@ -84,6 +84,18 @@
)\
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+#define SCM_DEFINE_INLINABLE(FNAME, PRIMNAME, IMSYM, REQ, OPT, VAR, ARGLIST,
DOCSTRING) \
+SCM_SNARF_HERE(
\
+static const char s_ ## FNAME [] = PRIMNAME; \
+SCM FNAME ARGLIST \
+) \
+SCM_SNARF_INIT(
\
+scm_c_define_inlinable_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
+ IMSYM); \
+) \
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST,
DOCSTRING) \
SCM_SNARF_HERE(\
static const char s_ ## FNAME [] = PRIMNAME; \
--- orig/libguile/tags.h
+++ mod/libguile/tags.h
@@ -542,32 +542,6 @@
#define SCM_ISYMP(n) (SCM_ITAG8 (n) == scm_tc8_isym)
#define SCM_MAKISYM(n) SCM_MAKE_ITAG8 ((n), scm_tc8_isym)
-#define SCM_IM_AND SCM_MAKISYM (0)
-#define SCM_IM_BEGIN SCM_MAKISYM (1)
-#define SCM_IM_CASE SCM_MAKISYM (2)
-#define SCM_IM_COND SCM_MAKISYM (3)
-#define SCM_IM_DO SCM_MAKISYM (4)
-#define SCM_IM_IF SCM_MAKISYM (5)
-#define SCM_IM_LAMBDA SCM_MAKISYM (6)
-#define SCM_IM_LET SCM_MAKISYM (7)
-#define SCM_IM_LETSTAR SCM_MAKISYM (8)
-#define SCM_IM_LETREC SCM_MAKISYM (9)
-#define SCM_IM_OR SCM_MAKISYM (10)
-#define SCM_IM_QUOTE SCM_MAKISYM (11)
-#define SCM_IM_SET_X SCM_MAKISYM (12)
-#define SCM_IM_DEFINE SCM_MAKISYM (13)
-#define SCM_IM_APPLY SCM_MAKISYM (14)
-#define SCM_IM_CONT SCM_MAKISYM (15)
-#define SCM_IM_DISPATCH SCM_MAKISYM (16)
-#define SCM_IM_SLOT_REF SCM_MAKISYM (17)
-#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18)
-#define SCM_IM_DELAY SCM_MAKISYM (19)
-#define SCM_IM_FUTURE SCM_MAKISYM (20)
-#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21)
-#define SCM_IM_ELSE SCM_MAKISYM (22)
-#define SCM_IM_ARROW SCM_MAKISYM (23)
-#define SCM_IM_NIL_COND SCM_MAKISYM (24) /* Multi-language support */
-#define SCM_IM_BIND SCM_MAKISYM (25) /* Multi-language support */
--- orig/test-suite/tests/syntax.test
+++ mod/test-suite/tests/syntax.test
@@ -775,9 +775,9 @@
(define (a x) (if (= x 0) 'a (b (- x 1))))
(define (b x) (if (= x 0) 'b (c (- x 1))))
(define (c x) (if (= x 0) 'c (a (- x 1))))
- (and (eq? 'a (a 0) (a 3))
- (eq? 'b (a 1) (a 4))
- (eq? 'c (a 2) (a 5))))
+ (and (eq? 'a (a 0)) (eq? 'a (a 3))
+ (eq? 'b (a 1)) (eq? 'b (a 4))
+ (eq? 'c (a 2)) (eq? 'c (a 5))))
(interaction-environment)))
(pass-if "internal defines with begin"
@@ -787,9 +787,9 @@
(begin
(define (b x) (if (= x 0) 'b (c (- x 1)))))
(define (c x) (if (= x 0) 'c (a (- x 1))))
- (and (eq? 'a (a 0) (a 3))
- (eq? 'b (a 1) (a 4))
- (eq? 'c (a 2) (a 5))))
+ (and (eq? 'a (a 0)) (eq? 'a (a 3))
+ (eq? 'b (a 1)) (eq? 'b (a 4))
+ (eq? 'c (a 2)) (eq? 'c (a 5))))
(interaction-environment))))
(pass-if "internal defines with empty begin"
@@ -799,9 +799,9 @@
(begin)
(define (b x) (if (= x 0) 'b (c (- x 1))))
(define (c x) (if (= x 0) 'c (a (- x 1))))
- (and (eq? 'a (a 0) (a 3))
- (eq? 'b (a 1) (a 4))
- (eq? 'c (a 2) (a 5))))
+ (and (eq? 'a (a 0)) (eq? 'a (a 3))
+ (eq? 'b (a 1)) (eq? 'b (a 4))
+ (eq? 'c (a 2)) (eq? 'c (a 5))))
(interaction-environment))))
(pass-if "internal defines with macro application"
@@ -813,9 +813,9 @@
(define (a x) (if (= x 0) 'a (b (- x 1))))
(my-define (b x) (if (= x 0) 'b (c (- x 1))))
(define (c x) (if (= x 0) 'c (a (- x 1))))
- (and (eq? 'a (a 0) (a 3))
- (eq? 'b (a 1) (a 4))
- (eq? 'c (a 2) (a 5)))))
+ (and (eq? 'a (a 0)) (eq? 'a (a 3))
+ (eq? 'b (a 1)) (eq? 'b (a 4))
+ (eq? 'c (a 2)) (eq? 'c (a 5)))))
(interaction-environment))))
(pass-if-exception "missing body expression"
built-in.i
/* -*- C -*-
Definitions of the various built-in macros and their unmemoizers. This
file is meant to be processed by `expand.h' and by `extract-imsyms.sh'. */
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", and, unmemoize_and)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", begin, unmemoize_begin)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", case, unmemoize_case)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", cond, unmemoize_cond)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", do, unmemoize_do)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", if, unmemoize_if)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", lambda, unmemoize_lambda)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", let, unmemoize_let)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", letstar, unmemoize_letstar)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", letrec, unmemoize_letrec)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", or, unmemoize_or)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", quote, unmemoize_quote)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", set_x, unmemoize_set_x)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", define, unmemoize_exprs)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", apply, unmemoize_apply)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", cont, unmemoize_atcall_cc)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", dispatch, unmemoize_exprs)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", slot_ref, unmemoize_atslot_ref)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", slot_set_x, unmemoize_atslot_set_x)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", delay, unmemoize_delay)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", call_with_values,
unmemoize_at_call_with_values)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", else, unmemoize_exprs)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", arrow, unmemoize_exprs)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", nil_cond, unmemoize_exprs) /*
Multi-language support */
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", bind, unmemoize_exprs) /*
Multi-language support */
/* SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", future, unmemoize_future) */
/* Inlineables (see `inlinable.i'). */
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atnullp, unmemoize_atnullp)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atpairp, unmemoize_atpairp)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atlistp, unmemoize_atlistp)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atcar, unmemoize_atcar)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atcdr, unmemoize_atcdr)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atcons, unmemoize_atcons)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", atnot, unmemoize_atnot)
SCM_DEFINE_BUILT_IN_MACRO ("address@hidden", ateqp, unmemoize_ateqp)
built-in-expand.h
/* Expanding built-in macro definitions from `built-in.i'. */
#ifndef BUILT_IN_MACRO_DISPATCH_LOGIC
# ifdef __GNUC__
/* We're relying on the ``labels as pointers'' GNU C extension. */
# define SCM_USE_DISPATCH_TABLES
# endif
# ifdef SCM_USE_DISPATCH_TABLES
# define BUILT_IN_MACRO_DISPATCH_TABLE(_prefix) \
isym_jump_table_ ## _prefix
# define BUILT_IN_MACRO_DISPATCH(_prefix, _isym) \
goto *((isym_jump_table_ ## _prefix)[ISYMNUM (_isym)]);
# define BUILT_IN_MACRO_CASE(_prefix, _cname) \
isym_handle_ ## _cname
# else
# define BUILT_IN_MACRO_DISPATCH_TABLE(_prefix) \
unused_isym_jump_table_ ## _prefix
# define BUILT_IN_MACRO_DISPATCH(_prefix, _isym) \
switch (ISYMNUM (_isym))
# define BUILT_IN_MACRO_CASE(_prefix, _cname) \
case ISYMNUM (scm_imsym_ ## _cname)
# endif
#endif
#undef SCM_DEFINE_BUILT_IN_MACRO
#if (defined EXTRACT_BUILT_IN_MACRO_UNMEMOIZERS)
# define SCM_DEFINE_BUILT_IN_MACRO(_name, _cname, _unmemoizer) \
(_unmemoizer),
#elif (defined EXTRACT_BUILT_IN_MACRO_NAMES)
# define SCM_DEFINE_BUILT_IN_MACRO(_name, _cname, _unmemoizer) \
(_name),
#elif (defined EXTRACT_BUILT_IN_MACRO_DISPATCH_TABLE)
# define SCM_DEFINE_BUILT_IN_MACRO(_name, _cname, _unmemoizer) \
&& isym_handle_ ## _cname,
#endif
extract-imsyms.sh
#!/bin/sh
# Copyright (C) 2006 Free Software Foundation, Inc.
# Written by Ludovic Courtès <address@hidden>
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
#
# Extracts built-in macro (immediate symbol) information and issue
# immediate symbol definitions (C macros) for use in `eval.c'
#
macro_count=0
grep '^SCM_DEFINE_BUILT_IN_MACRO' "$1" | \
sed -es'/^SCM_DEFINE_BUILT_IN_MACRO ("address@hidden",
\([A-Za-z_]\+\),.*$/\1/g' | \
while true
do
read macro_name
if test "x$macro_name" = "x"
then
break
else
echo "#define scm_imsym_$macro_name SCM_MAKISYM ($macro_count)"
macro_count="`expr $macro_count + 1`"
fi
done
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- Inlining calls to primitives,
Ludovic Courtès <=