Hi Andy,
Andy Wingo <wi...@pobox.com> skribis:
> Rather, something like:
>
> (define (truncate x)
> (match x
> ((<const>) x)
> ;; similar provably singly-valued cases here
> (else (make-primcall #f 'values (list x)))))
I’ve started poking at it and the main difficulty is that we now need to
know, for any procedure, whether it’s provably singly-valued.
I suspect it’s often the case that it cannot be proved, for instance
when a lambda calls a top-level. In all those cases, we’d end up
wrapping the expression in (values (list EXP)), which seems like a bad
idea.
Thoughts?
Thanks,
Ludo’.
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 634c6c9..b4f5144 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -99,6 +99,42 @@
(or (proc (vlist-ref vlist i))
(lp (1+ i)))))))
+(define (truncate-values x)
+ "Discard all but the first value of X."
+ (let loop ((x x))
+ (match x
+ (($ <const>) x)
+ (($ <lexical-ref>) x)
+ (($ <void>) x)
+ (($ <lexical-ref>) x)
+ (($ <primitive-ref>) x)
+ (($ <module-ref>) x)
+ (($ <toplevel-ref>) x)
+ (($ <conditional> src condition subsequent alternate)
+ (make-conditional src condition (loop subsequent) (loop alternate)))
+ (($ <application> src ($ <primitive-ref> _ 'values) (first _ ...))
+ first)
+ (($ <application> _ ($ <primitive-ref>))
+ ;; Assume all other primitives return at most one value.
+ x)
+ (($ <sequence> src (exps ... last))
+ (make-sequence src (append exps (list (loop last)))))
+ (($ <lambda>) x)
+ (($ <dynlet> src fluids vals body)
+ (make-dynlet src fluids vals (loop body)))
+ (($ <let> src names gensyms vals body)
+ (make-let src names gensyms vals (loop body)))
+ (($ <letrec> src in-order? names gensyms vals body)
+ (make-letrec src in-order? names gensyms vals (loop body)))
+ (($ <fix> src names gensyms vals body)
+ (make-fix src names gensyms vals body))
+ (($ <let-values> src exp body)
+ (make-let-values src exp (loop body)))
+ (else
+ (make-application (tree-il-src x)
+ (make-primitive-ref #f'values)
+ (list x))))))
+
;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and
;; singly-referenced lexicals.
@@ -278,8 +314,10 @@
(constant-value operand-constant-value set-operand-constant-value!))
(define* (make-operand var sym #:optional source visit)
+ ;; Bind SYM to VAR, with value SOURCE.
;; Bound operands are considered copyable until we prove otherwise.
- (%make-operand var sym visit source 0 #f (and source #t) #f #f))
+ (let ((source (if source (truncate-values source) source)))
+ (%make-operand var sym visit source 0 #f (and source #t) #f #f)))
(define (make-bound-operands vars syms sources visit)
(map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 5e02bd1..57fd1f4 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -664,6 +664,28 @@
(+ a b))))
(const 3))
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values.
+ (let ((x 1) (y 2))
+ (values x y))
+ (apply (primitive values) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values truncated.
+ (let ((x (values 1 'a)) (y 2))
+ (values x y))
+ (apply (primitive values) (const 1) (const 2)))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values truncated.
+ (or (values 1 2) 3)
+ (const 1))
+
+ (pass-if-peval resolve-primitives
+ ;; First order, multiple values truncated in arguments.
+ (+ (values 1 2 3) 2)
+ (const 3))
+
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
