(($ <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)
(($ <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)))
(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
(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)))))
(apply list args)))
(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)