Re: or values bug?

[ludo@gnu.org (Ludovic Courtès)]

[-- Attachment #1: Type: text/plain, Size: 637 bytes --]

Hi Andy,

Andy Wingo <wingo@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’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 3489 bytes --]

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))))