mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

Optimize closures with only required and rest arguments in eval

Browse source 
* module/ice-9/eval.scm: Pregenerate closures with rest arguments, as we
  do for fixed arguments.  This is important given the amount of (lambda
  args (apply foo args)) that we are doing lately.
This commit is contained in:
Andy Wingo 2013-10-23 19:01:03 +02:00
parent 8695854a7d
commit a4b64fa246
1 changed files with 45 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -102,6 +102,46 @@
(1- nreq) (1- nreq)
(cdr args))))))))))))) (cdr args)))))))))))))
;; Fast case for procedures with fixed arities and a rest argument.
(define-syntax make-rest-closure
(lambda (x)
(define *max-static-argument-count* 3)
(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 body env) (not (identifier? #'env))
#'(let ((e env))
(make-rest-closure eval nreq body e)))
((_ eval nreq body env)
#`(case nreq
#,@(map (lambda (nreq)
(let ((formals (make-formals nreq)))
#`((#,nreq)
(lambda (#,@formals . rest)
(eval body
(cons* rest #,@(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 (cons args 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 (define-syntax call
(lambda (x) (lambda (x)
(define *max-static-call-count* 4) (define *max-static-call-count* 4)
@ -212,8 +252,9 @@
(define primitive-eval (define primitive-eval
(let () (let ()
;; We pre-generate procedures with fixed arities, up to some number of ;; We pre-generate procedures with fixed arities, up to some number
;; arguments; see make-fixed-closure above. ;; of arguments, and some rest arities; see make-fixed-closure and
;; make-rest-closure above.
;; A unique marker for unbound keywords. ;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg)) (define unbound-arg (list 'unbound-arg))
@ -222,7 +263,7 @@
;; multiple arities, as with case-lambda. ;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt) (define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc (define alt-proc
(and alt ; (body docstring nreq ...) (and alt ; (body docstring nreq ...)
(let* ((body (car alt)) (let* ((body (car alt))
(spec (cddr alt)) (spec (cddr alt))
(nreq (car spec)) (nreq (car spec))
@ -413,9 +454,7 @@
(if (null? tail) (if (null? tail)
(make-fixed-closure eval nreq body (capture-env env)) (make-fixed-closure eval nreq body (capture-env env))
(if (null? (cdr tail)) (if (null? (cdr tail))
(make-general-closure (capture-env env) body (make-rest-closure eval nreq body (capture-env env))
nreq (car tail)
0 #f '() #f)
(apply make-general-closure (capture-env env) (apply make-general-closure (capture-env env)
body nreq tail))))) body nreq tail)))))
(when docstring (when docstring