diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-21 08:58:09 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-21 08:58:09 +0200 |
commit | 4f33b47591e823500d800ee4f9d98c8ae98ceab8 (patch) | |
tree | 5dceb596f5c6a01fa3cfac244dda0d7c61ead554 | |
parent | 65a32655253cdfcf4e2caf03a73ac66b05da5f71 (diff) | |
download | guile-4f33b47591e823500d800ee4f9d98c8ae98ceab8.tar.gz |
peval: inlining of let-values
* module/language/tree-il/optimize.scm (peval): Add support for
let-values. Try to inline the consumer into the body of the producer,
if there is only one return point, and we can figure out how many
values are being returned, and that number is compatible with the
consumer.
-rw-r--r-- | module/language/tree-il/optimize.scm | 95 |
1 files changed, 95 insertions, 0 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 5f053c17c..43cea5e76 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -192,6 +192,74 @@ it does not handle <fix> and <let-values>, it should be called before (lambda _ (values #f '())))) + (define (inline-values exp src names gensyms body) + (let loop ((exp exp)) + (match exp + ;; Some expression types are always singly-valued. + ((or ($ <const>) + ($ <void>) + ($ <lambda>) + ($ <lexical-ref>) + ($ <toplevel-ref>) + ($ <module-ref>) + ($ <primitive-ref>) + ($ <dynref>) + ($ <toplevel-set>) ; FIXME: these set! expressions + ($ <toplevel-define>) ; could return zero values in + ($ <module-set>)) ; the future + (and (= (length names) 1) + (make-let src names gensyms (list exp) body))) + (($ <application> src + ($ <primitive-ref> _ (? singly-valued-primitive? name))) + (and (= (length names) 1) + (make-let src names gensyms (list exp) body))) + + ;; Statically-known number of values. + (($ <application> src ($ <primitive-ref> _ 'values) vals) + (and (= (length names) (length vals)) + (make-let src names gensyms vals body))) + + ;; Not going to copy code into both branches. + (($ <conditional>) #f) + + ;; Bail on other applications. + (($ <application>) #f) + + ;; Propagate to tail positions. + (($ <let> src names gensyms vals body) + (let ((body (loop body))) + (and body + (make-let src names gensyms vals body)))) + (($ <letrec> src in-order? names gensyms vals body) + (let ((body (loop body))) + (and body + (make-letrec src in-order? names gensyms vals body)))) + (($ <fix> src names gensyms vals body) + (let ((body (loop body))) + (and body + (make-fix src names gensyms vals body)))) + (($ <let-values> src exp + ($ <lambda-case> src2 req opt rest kw inits gensyms body #f)) + (let ((body (loop body))) + (and body + (make-let-values src exp + (make-lambda-case src2 req opt rest kw + inits gensyms body #f))))) + (($ <dynwind> src winder body unwinder) + (let ((body (loop body))) + (and body + (make-dynwind src winder body unwinder)))) + (($ <dynlet> src fluids vals body) + (let ((body (loop body))) + (and body + (make-dynlet src fluids vals body)))) + (($ <sequence> src exps) + (match exps + ((head ... tail) + (let ((tail (loop tail))) + (and tail + (make-sequence src (append head (list tail))))))))))) + (define (make-values src values) (match values ((single) single) ; 1 value @@ -358,6 +426,21 @@ it does not handle <fix> and <let-values>, it should be called before (if (const? body*) body (make-fix src names gensyms vals body)))) + (($ <let-values> src producer + ($ <lambda-case> src2 req #f #f #f () gensyms body #f)) + ;; Peval both producer and consumer, then try to inline. If + ;; that succeeds, peval again. + (let* ((producer (maybe-unconst producer (loop producer env calls))) + (body (maybe-unconst body (loop body env calls)))) + (cond + ((inline-values producer src2 req gensyms body) + => (lambda (exp) (loop exp env calls))) + (else + (make-let-values + src producer + (make-lambda-case src2 req #f #f #f '() gensyms body #f)))))) + (($ <let-values>) + exp) (($ <dynwind> src winder body unwinder) (make-dynwind src (loop winder env calls) (loop body env calls) @@ -401,6 +484,18 @@ it does not handle <fix> and <let-values>, it should be called before (make-conditional src condition (loop subsequent env calls) (loop alternate env calls))))) + (($ <application> src + ($ <primitive-ref> _ '@call-with-values) + (producer + ($ <lambda> _ _ + (and consumer + ;; No optional or kwargs. + ($ <lambda-case> + _ req #f rest #f () gensyms body #f))))) + (loop (make-let-values src (make-application src producer '()) + consumer) + env calls)) + (($ <application> src orig-proc orig-args) ;; todo: augment the global env with specialized functions (let* ((proc (loop orig-proc env calls)) |