summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/eval.c5
-rw-r--r--libguile/memoize.c16
-rw-r--r--module/ice-9/eval.scm50
3 files changed, 55 insertions, 16 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index ec19c2345..0bd54a0ef 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -254,8 +254,8 @@ eval (SCM x, SCM env)
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
proc = eval (CAR (mx), env);
-
- mx = CDR (mx);
+ /* int nargs = CADR (mx); */
+ mx = CDDR (mx);
if (BOOT_CLOSURE_P (proc))
{
@@ -289,6 +289,7 @@ eval (SCM x, SCM env)
else
{
SCM rest = SCM_EOL;
+ /* FIXME: use alloca */
for (; scm_is_pair (mx); mx = CDR (mx))
rest = scm_cons (eval (CAR (mx), env), rest);
return scm_vm_apply (scm_the_vm (), proc, scm_reverse (rest));
diff --git a/libguile/memoize.c b/libguile/memoize.c
index ae3bbea16..c544f21b0 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -207,8 +207,8 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_CONT, proc)
#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
-#define MAKMEMO_CALL(proc, args) \
- MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
+#define MAKMEMO_CALL(proc, nargs, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
#define MAKMEMO_LEX_REF(n) \
MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
#define MAKMEMO_LEX_SET(n, val) \
@@ -345,11 +345,15 @@ memoize (SCM exp, SCM env)
return trans (exp, env);
else
{
+ SCM proc;
SCM args = SCM_EOL;
- for (; scm_is_pair (exp); exp = CDR (exp))
+ int nargs = 0;
+ proc = memoize (CAR (exp), env);
+ for (exp = CDR (exp); scm_is_pair (exp); exp = CDR (exp), nargs++)
args = scm_cons (memoize (CAR (exp), env), args);
if (scm_is_null (exp))
- return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED));
+ return MAKMEMO_CALL (proc, nargs,
+ scm_reverse_x (args, SCM_UNDEFINED));
else
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
}
@@ -566,6 +570,7 @@ scm_m_cond (SCM expr, SCM env)
i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
MAKMEMO_CALL (memoize (CADDR (clause),
scm_cons (tmp, new_env)),
+ 1,
scm_list_1 (MAKMEMO_LEX_REF (0))),
MAKMEMO_QUOTE (SCM_UNSPECIFIED));
SCM_SETCDR (loc,
@@ -793,6 +798,7 @@ memoize_named_let (const SCM expr, SCM env)
memoize_sequence (CDDDR (expr),
memoize_env_extend (env, rvariables)))),
MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
+ nreq,
memoize_exprs (inits, env)))));
}
@@ -1054,7 +1060,7 @@ unmemoize (const SCM expr)
case SCM_M_BEGIN:
return scm_cons (scm_sym_begin, unmemoize_exprs (args));
case SCM_M_CALL:
- return unmemoize_exprs (args);
+ return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
case SCM_M_CONT:
return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
case SCM_M_CALL_WITH_VALUES:
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index e82ebe446..b3721e4e2 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -55,10 +55,9 @@
(and (current-module) the-root-module)
env)))))
- (define *max-static-argument-count* 8)
-
(define-syntax make-closure
(lambda (x)
+ (define *max-static-argument-count* 8)
(define (make-formals n)
(map (lambda (i)
(datum->syntax
@@ -107,6 +106,43 @@
(1- nreq)
(cdr args)))))))))))))
+ (define-syntax call
+ (lambda (x)
+ (define *max-static-call-count* 4)
+ (syntax-case x ()
+ ((_ eval proc nargs args env) (identifier? #'env)
+ #`(case nargs
+ #,@(map (lambda (nargs)
+ #`((#,nargs)
+ (proc
+ #,@(map
+ (lambda (n)
+ (let lp ((n n) (args #'args))
+ (if (zero? n)
+ #`(eval (car #,args) env)
+ (lp (1- n) #`(cdr #,args)))))
+ (iota nargs)))))
+ (iota *max-static-call-count*))
+ (else
+ (apply proc
+ #,@(map
+ (lambda (n)
+ (let lp ((n n) (args #'args))
+ (if (zero? n)
+ #`(eval (car #,args) env)
+ (lp (1- n) #`(cdr #,args)))))
+ (iota *max-static-call-count*))
+ (let lp ((exps #,(let lp ((n *max-static-call-count*)
+ (args #'args))
+ (if (zero? n)
+ args
+ (lp (1- n) #`(cdr #,args)))))
+ (args '()))
+ (if (null? exps)
+ (reverse args)
+ (lp (cdr exps)
+ (cons (eval (car exps) env) args)))))))))))
+
;; This macro could be more straightforward if the compiler had better
;; copy propagation. As it is we do some copy propagation by hand.
(define-syntax mx-bind
@@ -189,14 +225,10 @@
(('apply (f args))
(apply (eval f env) (eval args env)))
- (('call (f . args))
+ (('call (f nargs . args))
(let ((proc (eval f env)))
- (let eval-args ((in args) (out '()))
- (if (null? in)
- (apply proc (reverse out))
- (eval-args (cdr in)
- (cons (eval (car in) env) out))))))
-
+ (call eval proc nargs args env)))
+
(('call/cc proc)
(call/cc (eval proc env)))