diff options
| -rw-r--r-- | module/language/tree-il/peval.scm | 24 | ||||
| -rw-r--r-- | test-suite/tests/peval.test | 9 |
2 files changed, 29 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))))) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 8f237b8ef..45e322aad 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -984,6 +984,15 @@ (primcall list (const 1) (const 2))) (pass-if-peval + ;; When we can't inline let-values but can prove that the producer + ;; has just one value, reduce to "let" (which can then fold + ;; further). + (call-with-values (lambda () (if foo 1 2)) + (lambda args + (apply values args))) + (if (toplevel foo) (const 1) (const 2))) + + (pass-if-peval ;; Constant folding: cons of #nil does not make list (cons 1 #nil) (primcall cons (const 1) (const '#nil))) |