mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

interpreted closures cons less.

Browse source 
* 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).
This commit is contained in:
Andy Wingo 2009-12-13 16:18:39 +01:00
parent 271a32dbc2
commit 4abb824cdb
3 changed files with 55 additions and 30 deletions
Download patch file Download diff file Expand all files Collapse all files

72
module/ice-9/eval.scm
View file

@ -55,6 +55,58 @@
(and (current-module) the-root-module)
env)))))
(define *max-static-argument-count* 8)
(define-syntax make-closure
(lambda (x)
(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)))))))))))))
;; 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,25 +178,7 @@
(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)

4
test-suite/tests/goops.test
View file

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

5
test-suite/tests/hooks.test
View file

@ -52,11 +52,6 @@
(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)))
(pass-if-exception "illegal hook"
exception:wrong-type-arg