diff options
| author | Andy Wingo <wingo@pobox.com> | 2013-06-16 15:02:34 +0200 |
|---|---|---|
| committer | Andy Wingo <wingo@pobox.com> | 2013-06-16 15:02:34 +0200 |
| commit | e6450062a19bf5d0072d117b69be95c2641c23ab (patch) | |
| tree | ad75176969f9474118a04b0c938671b2a29b99af /module/language/tree-il | |
| parent | b34b66b346ef7c09878112d7cf6d757bb1906344 (diff) | |
| download | guile-e6450062a19bf5d0072d117b69be95c2641c23ab.tar.gz | |
Reduce call-with-values to let for singly-valued producers
* module/language/tree-il/peval.scm (singly-valued-expression?): Add
support for conditionals. In the future we should add more
expressions here.
(peval): Don't inline values into the body of a dynwind, as that could
cause the consumer to run in the wrong dynamic context.
If the producer is singly-valued and the consumer just has a rest arg,
reduce to "let" and cons up a list in the consumer. This may reduce
further.
* test-suite/tests/peval.test ("partial evaluation"): Add a test.
Diffstat (limited to 'module/language/tree-il')
| -rw-r--r-- | module/language/tree-il/peval.scm | 24 |
1 files changed, 20 insertions, 4 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 3755380ec..627114312 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -101,6 +101,9 @@ (($ <primcall> _ (? singly-valued-primitive?)) #t) (($ <primcall> _ 'values (val)) #t) (($ <lambda>) #t) + (($ <conditional> _ test consequent alternate) + (and (singly-valued-expression? consequent) + (singly-valued-expression? alternate))) (else #f))) (define (truncate-values x) @@ -538,6 +541,10 @@ top-level bindings from ENV and return the resulting expression." (($ <prompt>) #f) (($ <abort>) #f) + ;; Bail on dynwinds, as that would cause the consumer to run in + ;; the wrong dynamic context. + (($ <dynwind>) #f) + ;; Propagate to tail positions. (($ <let> src names gensyms vals body) (let ((body (loop body))) @@ -558,10 +565,6 @@ top-level bindings from ENV and return the resulting expression." (make-let-values src exp (make-lambda-case src2 req opt rest kw inits gensyms body #f))))) - (($ <dynwind> src winder pre body post unwinder) - (let ((body (loop body))) - (and body - (make-dynwind src winder pre body post unwinder)))) (($ <dynlet> src fluids vals body) (let ((body (loop body))) (and body @@ -975,6 +978,19 @@ top-level bindings from ENV and return the resulting expression." (for-tail (make-let src (list req-name) (list req-sym) (list producer) body))) + ((and ($ <lambda-case> src () #f rest #f () (rest-sym) body #f) + (? (lambda _ (singly-valued-expression? producer)))) + (let ((tmp (gensym "tmp "))) + (record-new-temporary! 'tmp tmp 1) + (for-tail + (make-let + src (list 'tmp) (list tmp) (list producer) + (make-let + src (list rest) (list rest-sym) + (list + (make-primcall #f 'list + (list (make-lexical-ref #f 'tmp tmp)))) + body))))) (($ <lambda-case> src req opt rest #f inits gensyms body #f) (let* ((nmin (length req)) (nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) |