[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-213-g93
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-213-g9331f91 |
|
Date: |
Sun, 13 Dec 2009 16:27:54 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=9331f91cc411fc2a09a59308bb889f3f5f735e49
The branch, master has been updated
via 9331f91cc411fc2a09a59308bb889f3f5f735e49 (commit)
via 4abb824cdbd5f16a836da8ab75cc24a6a53f3b35 (commit)
from 271a32dbc25825ffa3cd880b4260272c0ddc7cf1 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 9331f91cc411fc2a09a59308bb889f3f5f735e49
Author: Andy Wingo <address@hidden>
Date: Sun Dec 13 17:05:10 2009 +0100
primitive-eval passes first N args on stack directly, not via apply
* libguile/memoize.c (MAKMEMO_CALL): Memoize in the number of arguments
at the call site.
(memoize, scm_m_cond, memoize_named_let, unmemoize):
* libguile/eval.c (eval): Adapt to changes in call memoization.
* module/ice-9/eval.scm (primitive-eval): For calls, pass the first N
arguments directly on the stack, and only the rest as a consed
argument list to apply. Currently N is 4.
commit 4abb824cdbd5f16a836da8ab75cc24a6a53f3b35
Author: Andy Wingo <address@hidden>
Date: Sun Dec 13 16:18:39 2009 +0100
interpreted closures cons less.
* module/ice-9/eval.scm (primitive-eval): When making a closure with N
formals, actuall return a closure with N formals, if N is less than
*max-static-argument-count*, which currently is 8. If N is greater
than 8, do the arg-parsing loop as we did before. Requires some
macrology, but should reduce unnecessary consing for interpreted
closures.
* test-suite/tests/goops.test:
* test-suite/tests/hooks.test: Now that checks like (thunk? foo) are
going to work as a for interpreted code, remove some (throw
'unresolved).
-----------------------------------------------------------------------
Summary of changes:
libguile/eval.c | 5 +-
libguile/memoize.c | 16 ++++--
module/ice-9/eval.scm | 120 +++++++++++++++++++++++++++++++++----------
test-suite/tests/goops.test | 4 --
test-suite/tests/hooks.test | 7 +--
5 files changed, 108 insertions(+), 44 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index ec19c23..0bd54a0 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 ae3bbea..c544f21 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 e2746dc..b3721e4 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -55,6 +55,94 @@
(and (current-module) the-root-module)
env)))))
+ (define-syntax make-closure
+ (lambda (x)
+ (define *max-static-argument-count* 8)
+ (define (make-formals n)
+ (map (lambda (i)
+ (datum->syntax
+ x
+ (string->symbol
+ (string (integer->char (+ (char->integer #\a) i))))))
+ (iota n)))
+ (syntax-case x ()
+ ((_ eval nreq rest? body env) (not (identifier? #'env))
+ #'(let ((e env))
+ (make-closure eval nreq rest? body e)))
+ ((_ eval nreq rest? body env)
+ #`(case nreq
+ #,@(map (lambda (nreq)
+ (let ((formals (make-formals nreq)))
+ #`((#,nreq)
+ (if rest?
+ (lambda (#,@formals . rest)
+ (eval body
+ (cons* rest #,@(reverse formals)
+ env)))
+ (lambda (#,@formals)
+ (eval body
+ (cons* #,@(reverse formals) env)))))))
+ (iota *max-static-argument-count*))
+ (else
+ #,(let ((formals (make-formals *max-static-argument-count*)))
+ #`(lambda (#,@formals . more)
+ (let lp ((new-env (cons* #,@(reverse formals) env))
+ (nreq (- nreq #,*max-static-argument-count*))
+ (args more))
+ (if (zero? nreq)
+ (eval body
+ (if rest?
+ (cons args new-env)
+ (if (not (null? args))
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of
arguments"
+ '() #f)
+ new-env)))
+ (if (null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f)
+ (lp (cons (car args) new-env)
+ (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
@@ -126,26 +214,8 @@
(cons (eval (car inits) env) new-env)))))
(('lambda (nreq rest? . body))
- (let ((env (capture-env env)))
- (lambda args
- (let lp ((env env) (nreq nreq) (args args))
- (if (zero? nreq)
- (eval body
- (if rest?
- (cons args env)
- (if (not (null? args))
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f)
- env)))
- (if (null? args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f)
- (lp (cons (car args) env)
- (1- nreq)
- (cdr args))))))))
-
+ (make-closure eval nreq rest? body (capture-env env)))
+
(('quote x)
x)
@@ -155,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)))
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index f2ae2b7..908d1e7 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -167,10 +167,6 @@
(expect-fail "bad init-thunk"
(begin
- ;; Currently UPASSing because we can't usefully get
- ;; any arity information out of interpreted
- ;; procedures. A FIXME I guess.
- (throw 'unresolved)
(catch #t
(lambda ()
(eval '(define-class <foo> ()
diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test
index 3e07876..0987f8c 100644
--- a/test-suite/tests/hooks.test
+++ b/test-suite/tests/hooks.test
@@ -52,12 +52,7 @@
(pass-if-exception "illegal proc"
exception:wrong-type-arg
(let ((x (make-hook 1)))
- ;; Currently fails to raise an exception
- ;; because we can't usefully get any arity
- ;; information out of interpreted procedures. A
- ;; FIXME I guess.
- (throw 'unresolved)
- (add-hook! x bad-proc)))
+ (add-hook! x bad-proc)))
(pass-if-exception "illegal hook"
exception:wrong-type-arg
(add-hook! '(foo) proc1)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-213-g9331f91,
Andy Wingo <=