diff options
-rw-r--r-- | libguile/eval.c | 5 | ||||
-rw-r--r-- | libguile/memoize.c | 16 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 50 |
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))) |