summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/optimize.scm95
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))