From 9a366730f4dd8c797b4e6fa7f765bf0e5c2b3725 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 30 Dec 2018 08:15:55 -0700
Subject: [PATCH] cp0: move only known-single-valued out of single-value
 context

Aviod turning an error like

 (let ([x (values 1 2)]) x)

or

 (car (list (values 1 2)))

into a program that returns multiple values.

original commit: 4efb3d6f226d9131f87023e45ff2b7e4713da8ae
---
 LOG           |   3 ++
 mats/cp0.ms   | 102 ++++++++++++++++++++++++++++++++++----------------
 s/cmacros.ss  |  13 ++++---
 s/cp0.ss      |  93 ++++++++++++++++++++++++++++++++++-----------
 s/primdata.ss |   6 +--
 s/syntax.ss   |   2 +-
 6 files changed, 155 insertions(+), 64 deletions(-)

diff --git a/LOG b/LOG
index e5aae978a0..e341385a5b 100644
--- a/LOG
+++ b/LOG
@@ -1027,3 +1027,6 @@
     cpnanopass.ss, x86_64.ss, x86.ss, foreign2.c, foreign.ms
 - added initialization of seginfo sorted and trigger_ephemerons fields.
     segment.c
+- adjust cp0 to avoid turning errors like `(let ([x (values 1 2)]) x)`
+  into programs that return multiple values
+    cp0.ss, primdata.ss, cmacros.ss, syntax.ss, cp0.ms
diff --git a/mats/cp0.ms b/mats/cp0.ms
index e1755e7b57..ccc3ddf34c 100644
--- a/mats/cp0.ms
+++ b/mats/cp0.ms
@@ -1984,13 +1984,13 @@
            ((begin (#%write 'b) #%car)
             (begin (#%write 'c)
               ((begin (#%write 'd) #%cons)
-               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'e) (add1 ($xxx)))
                (begin (#%write 'f) ($yyy))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'e) ($xxx))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) ($xxx))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'e) (#3%add1 ($xxx)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'e) (#2%add1 ($xxx)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -1998,14 +1998,14 @@
            ((begin (#%write 'b) #%car)
             (begin (#%write 'c)
               ((begin (#%write 'd) #%list)
-               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'e) (add1 ($xxx)))
                (begin (#%write 'f) ($yyy))
                (begin (#%write 'g) ($zzz))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -2013,14 +2013,14 @@
            ((begin (#%write 'b) #%car)
             (begin (#%write 'c)
               ((begin (#%write 'd) #%list*)
-               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'e) (add1 ($xxx)))
                (begin (#%write 'f) ($yyy))
                (begin (#%write 'g) ($zzz))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -2028,14 +2028,14 @@
            ((begin (#%write 'b) #%car)
             (begin (#%write 'c)
               ((begin (#%write 'd) #%cons*)
-               (begin (#%write 'e) ($xxx))
+               (begin (#%write 'e) (add1 ($xxx)))
                (begin (#%write 'f) ($yyy))
                (begin (#%write 'g) ($zzz))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) ($xxx))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) ($xxx))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'f) ($yyy) (#3%write 'g) ($zzz) (#3%write 'e) (#3%add1 ($xxx)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'f) ($yyy) (#2%write 'g) ($zzz) (#2%write 'e) (#2%add1 ($xxx)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -2044,12 +2044,12 @@
             (begin (#%write 'c)
               ((begin (#%write 'd) #%cons)
                (begin (#%write 'e) ($xxx))
-               (begin (#%write 'f) ($yyy))))))))
+               (begin (#%write 'f) (add1 ($yyy)))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -2103,12 +2103,12 @@
             (begin (#%write 'c)
               ((begin (#%write 'd) #%list*)
                (begin (#%write 'e) ($xxx))
-               (begin (#%write 'f) ($yyy))))))))
+               (begin (#%write 'f) (add1 ($yyy)))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -2117,12 +2117,12 @@
             (begin (#%write 'c)
               ((begin (#%write 'd) #%cons*)
                (begin (#%write 'e) ($xxx))
-               (begin (#%write 'f) ($yyy))))))))
+               (begin (#%write 'f) (add1 ($yyy)))))))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
       (expand/optimize
@@ -2190,14 +2190,14 @@
             (begin (write 'c)
               ((begin (write 'd) vector)
                (begin (write 'e) ($xxx))
-               (begin (write 'f) ($yyy))
+               (begin (write 'f) (add1 ($yyy)))
                (begin (write 'g) ($zzz))))
             (begin (write 'h) 1)))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
       (expand/optimize
@@ -2244,14 +2244,14 @@
             (begin (write 'c)
               ((begin (write 'd) list)
                (begin (write 'e) ($xxx))
-               (begin (write 'f) ($yyy))
+               (begin (write 'f) (add1 ($yyy)))
                (begin (write 'g) ($zzz))))
             (begin (write 'h) 1)))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
       (expand/optimize
@@ -2260,14 +2260,14 @@
             (begin (write 'c)
               ((begin (write 'd) list*)
                (begin (write 'e) ($xxx))
-               (begin (write 'f) ($yyy))
+               (begin (write 'f) (add1 ($yyy)))
                (begin (write 'g) ($zzz))))
             (begin (write 'h) 1)))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
       (expand/optimize
@@ -2276,14 +2276,14 @@
             (begin (write 'c)
               ((begin (write 'd) cons*)
                (begin (write 'e) ($xxx))
-               (begin (write 'f) ($yyy))
+               (begin (write 'f) (add1 ($yyy)))
                (begin (write 'g) ($zzz))))
             (begin (write 'h) 1)))))
     ; other possibilities exist but are too many to list and too difficult to construct with $permutations.
     ; if you see a problem, convert to use $check-writes (defined above)
     (if (= (optimize-level) 3)
-        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) ($yyy))
-        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) ($yyy))))
+        '(begin (#3%write 'a) (#3%write 'b) (#3%write 'h) (#3%write 'c) (#3%write 'd) (#3%write 'e) ($xxx) (#3%write 'g) ($zzz) (#3%write 'f) (#3%add1 ($yyy)))
+        '(begin (#2%write 'a) (#2%write 'b) (#2%write 'h) (#2%write 'c) (#2%write 'd) (#2%write 'e) ($xxx) (#2%write 'g) ($zzz) (#2%write 'f) (#2%add1 ($yyy)))))
   (equivalent-expansion?
     (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level (max (optimize-level) 2)])
       (expand/optimize
@@ -2828,3 +2828,39 @@
         `(lambda (x) (= x x))) ; x could be +nan.0
       `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x))))
 )
+
+(mat cp0-non-tail
+  ;; Make sure that an expression that might return multiple values is
+  ;; not moved out of a position that expects a single result.
+  (begin
+    (define (simplify-only-nontail? mk)
+      (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f])
+        (and
+         (equivalent-expansion?
+          (expand/optimize `(lambda (g) ,(mk `g)))
+          '(lambda (g) g))
+         (not (equivalent-expansion?
+               (expand/optimize `(lambda (g) ,(mk `(g))))
+               '(lambda (g) (g))))
+         (not (equivalent-expansion?
+               (expand/optimize `(lambda () (lambda (g) ,(mk `(g)))))
+               '(lambda () (lambda (g) (g)))))
+         (equivalent-expansion?
+          (expand/optimize `(lambda (g) (list ,(mk `(g)))))
+          (if (eqv? (optimize-level) 3)
+              '(lambda (g) (#3%list (g)))
+              '(lambda (g) (#2%list (g)))))
+         (equivalent-expansion?
+          (expand/optimize `(lambda (g) (if ,(mk `(g)) 1 2)))
+          '(lambda (g) (if (g) 1 2))))))
+     #t)
+   (simplify-only-nontail? (lambda (e) `(let ([x ,e]) x)))
+   (simplify-only-nontail? (lambda (e) `(letrec ([x ,e]) x)))
+   (simplify-only-nontail? (lambda (e) `(values ,e)))
+   (simplify-only-nontail? (lambda (e) `(list* ,e)))
+   (simplify-only-nontail? (lambda (e) `(append ,e)))
+   (simplify-only-nontail? (lambda (e) `(append! ,e)))
+   (simplify-only-nontail? (lambda (e) `(car (list ,e))))
+   (simplify-only-nontail? (lambda (e) `(car (cons ,e 2))))
+   (simplify-only-nontail? (lambda (e) `(cdr (cons 2 ,e))))
+)
diff --git a/s/cmacros.ss b/s/cmacros.ss
index bd188e982a..0a5a0d4391 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -1562,18 +1562,19 @@
   (ieee                     #b00000000000000000010000)
   (proc                     #b00000000000000000100000)
   (discard                  #b00000000000000001000000)
-  (unrestricted             #b00000000000000010000000)
-  (true                     #b00000000000000100000000)
-  (mifoldable               #b00000000000001000000000)
+  (single-valued            #b00000000000000010000000)
+  (true                 (or #b00000000000000100000000 single-valued))
+  (mifoldable           (or #b00000000000001000000000 single-valued))
   (cp02                     #b00000000000010000000000)
   (cp03                     #b00000000000100000000000)
   (system-keyword           #b00000000001000000000000)
   (r6rs                     #b00000000010000000000000)
-  (pure                 (or #b00000000100000000000000 discard))
+  (pure                 (or #b00000000100000000000000 discard single-valued))
   (library-uid              #b00000001000000000000000)
-  (boolean-valued           #b00000010000000000000000)
+  (boolean-valued       (or #b00000010000000000000000 single-valued))
   (abort-op                 #b00000100000000000000000)
   (unsafe                   #b00001000000000000000000)
+  (unrestricted             #b00010000000000000000000)
   (arith-op                 (or proc pure true))
   (alloc                    (or proc discard true))
   ; would be nice to check that these and only these actually have cp0 partial folders
@@ -1589,6 +1590,8 @@
   (simple                        #b0000100000)
   (boolean-valued-known          #b0001000000)
   (boolean-valued                #b0010000000)
+  (single-valued-nontail-known   #b0100000000)
+  (single-valued-nontail         #b1000000000)
 )
 
 (define-syntax define-flag-field
diff --git a/s/cp0.ss b/s/cp0.ss
index fc599722b4..e18dcb317d 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -755,6 +755,14 @@
            (bump sc 1)
            `(if ,e1 ,e2 ,e3)])))
 
+    (define make-nontail
+      (lambda (ctxt e)
+        (if (or (not (eq? (app-ctxt ctxt) 'tail))
+                (single-valued-nontail? e))
+            e
+            (let ([tmp (cp0-make-temp #f)])
+              (build-let (list tmp) (list e) (build-ref tmp))))))
+
     (define result-exp
       (lambda (e)
         (nanopass-case (Lsrc Expr) e
@@ -879,7 +887,7 @@
             ((ids->do-clause '()) clause)
             #t))))
 
-    (module (pure? ivory? simple? simple/profile? boolean-valued?)
+    (module (pure? ivory? simple? simple/profile? boolean-valued? single-valued-nontail?)
       (define-syntax make-$memoize
         (syntax-rules ()
           [(_ flag-known flag)
@@ -1140,6 +1148,43 @@
               [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #f]
               [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #f]
               [(pariah) #f]
+              [else ($oops who "unrecognized record ~s" e)]))))
+
+      (define-who single-valued-nontail?
+        (lambda (e)
+          (with-memoize (single-valued-nontail-known single-valued-nontail) e
+            ; known to produce a single value, and does not observe
+            ; or affect the immediate continuation frame (so removing
+            ; (an enclosing frame would be ok)
+            (nanopass-case (Lsrc Expr) e
+              [(quote ,d) #t]
+              [(call ,preinfo ,e ,e* ...)
+               (nanopass-case (Lsrc Expr) e
+                 [,pr (all-set? (prim-mask single-valued) (primref-flags pr))]
+                 [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
+                  (guard (fx= interface (length e*)))
+                  (memoize (single-valued-nontail? body))]
+                 [else #f])]
+              [(ref ,maybe-src ,x) #t]
+              [(case-lambda ,preinfo ,cl* ...) #t]
+              [(if ,e1 ,e2 ,e3) (memoize (and (single-valued-nontail? e2) (single-valued-nontail? e3)))]
+              [(seq ,e1 ,e2) (memoize (single-valued-nontail? e2))]
+              [(set! ,maybe-src ,x ,e) #t]
+              [(immutable-list (,e* ...) ,e) #t]
+              [(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued-nontail? body))]
+              [(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued-nontail? body))]
+              [,pr #t]
+              [(record-cd ,rcd ,rtd-expr ,e) #t]
+              [(record-ref ,rtd ,type ,index ,e) #t]
+              [(record-set! ,rtd ,type ,index ,e1 ,e2) #t]
+              [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) #t]
+              [(record-type ,rtd ,e) #t]
+              [(record ,rtd ,rtd-expr ,e* ...) #t]
+              [(pariah) #t]
+              [(profile ,src) #t]
+              [(cte-optimization-loc ,box ,e) (memoize (single-valued-nontail? e))]
+              [(moi) #t]
+              [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
               [else ($oops who "unrecognized record ~s" e)])))))
 
     (define find-call-lambda-clause
@@ -1271,7 +1316,9 @@
                    [(and (= (length id*) 1)
                          (nanopass-case (Lsrc Expr) body
                            [(ref ,maybe-src ,x) (eq? x (car id*))]
-                           [else #f]))
+                           [else #f])
+                         (or (not (eq? (app-ctxt ctxt) 'tail))
+                             (single-valued-nontail? (car rhs*))))
                     ; (let ((x e)) x) => e
                     ; x is clearly not assigned, even if flags are polluted and say it is
                     (car rhs*)]
@@ -1609,7 +1656,7 @@
                [else (residualize-ref maybe-src id sc)])]
             [,pr
               (context-case ctxt
-                [(value)
+                [(value tail)
                  (if (all-set? (prim-mask (or primitive proc)) (primref-flags pr))
                      rhs
                      (residualize-ref maybe-src id sc))]
@@ -2117,9 +2164,9 @@
         [args #f])
 
       (define-inline 2 (cons* list* values append append!)
-        [(x) (let ((xval (value-visit-operand! x)))
+        [(x) (begin
                (residualize-seq (list x) '() ctxt)
-               xval)]
+               (make-nontail ctxt (value-visit-operand! x)))]
         [args #f])
 
       (define-inline 2 vector
@@ -4173,19 +4220,19 @@
             (and (not (null? e*))
                  (begin
                    (residualize-seq '() (list ?x) ctxt)
-                   (car e*)))]
+                   (make-nontail ctxt (car e*))))]
            [(call ,preinfo ,pr ,e1 ,e2)
             (guard (eq? (primref-name pr) 'cons))
             (residualize-seq (list ?x) '() ctxt)
             (non-result-exp (operand-value ?x)
-              (make-seq (app-ctxt ctxt) e2 e1))]
+              (make-seq (app-ctxt ctxt) e2 (make-nontail ctxt e1)))]
            [(call ,preinfo ,pr ,e* ...)
             (guard (memq (primref-name pr) '(list list* cons*)) (not (null? e*)))
             (residualize-seq (list ?x) '() ctxt)
             (non-result-exp (operand-value ?x)
               (fold-right
                 (lambda (e1 e2) (make-seq (app-ctxt ctxt) e1 e2))
-                (car e*)
+                (make-nontail ctxt (car e*))
                 (cdr e*)))]
            [else #f])])
 
@@ -4203,7 +4250,7 @@
             (guard (eq? (primref-name pr) 'cons))
             (residualize-seq (list ?x) '() ctxt)
             (non-result-exp (operand-value ?x)
-              (make-seq (app-ctxt ctxt) e1 e2))]
+              (make-seq (app-ctxt ctxt) e1 (make-nontail ctxt e2)))]
            [(call ,preinfo ,pr ,e* ...)
             (guard (eq? (primref-name pr) 'list) (not (null? e*)))
             (residualize-seq (list ?x) '() ctxt)
@@ -4233,7 +4280,7 @@
                        (residualize-seq (list ?x ?i) '() ctxt)
                        (non-result-exp (operand-value ?i) ; do first ...
                          (non-result-exp (operand-value ?x) ; ... so we keep ?x related side effects together
-                           e)))))))
+                           (make-nontail ctxt e))))))))
 
         (define tryref
           (lambda (ctxt ?x ?i seqprim maybe-pred)
@@ -4545,7 +4592,7 @@
            (let ([x ($symbol-name name)])
              (if (pair? x) (cdr x) x))))
        (context-case ctxt
-         [(value)
+         [(value tail)
           (bump sc 1)
           `(case-lambda ,preinfo
              ,(let f ([cl* cl*] [mask 0])
@@ -4558,7 +4605,7 @@
                              (f (cdr cl*) new-mask)
                              (cons
                                (with-extended-env ((env x*) (env x* #f))
-                                 `(clause (,x* ...) ,interface ,(cp0 body 'value env sc wd #f name)))
+                                 `(clause (,x* ...) ,interface ,(cp0 body 'tail env sc wd #f name)))
                                (f (cdr cl*) new-mask))))])))
              ...)]
          [(effect) void-rec]
@@ -4591,11 +4638,13 @@
                                   (make-if ctxt sc e1
                                     true-rec
                                     (do-e3))]))
-                             (if (eq? (app-ctxt ctxt) 'value)
-                                 (let ([e1 (value-visit-operand! (car (app-opnds ctxt)))])
-                                   (and (boolean-valued? e1) (finish e1)))
-                                 (and (eq? (app-ctxt ctxt) 'test)
-                                      (finish (test-visit-operand! (car (app-opnds ctxt)))))))]
+                             (let ([r-ctxt (app-ctxt ctxt)])
+                               (if (or (eq? r-ctxt 'value)
+                                       (eq? r-ctxt 'tail))
+                                   (let ([e1 (visit-operand! (car (app-opnds ctxt)) r-ctxt)])
+                                     (and (boolean-valued? e1) (finish e1)))
+                                   (and (eq? (app-ctxt ctxt) 'test)
+                                        (finish (test-visit-operand! (car (app-opnds ctxt))))))))]
                           [else #f]))
                    (cp0-let preinfo ids body ctxt env sc wd name moi))]
               [() (cp0 ir 'value env sc wd name moi)]))])]
@@ -4604,7 +4653,7 @@
       [(letrec* ([,x* ,e*] ...) ,body)
        (cp0-rec-let #t x* e* body ctxt env sc wd name moi)]
       [,pr (context-case ctxt
-             [(value) (bump sc 1) pr]
+             [(value tail) (bump sc 1) pr]
              [(effect) void-rec]
              [(test)
               (if (all-set? (prim-mask proc) (primref-flags pr))
@@ -4613,16 +4662,16 @@
              [(app) (fold-primref pr ctxt sc wd name moi)])]
       [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type)
        (context-case ctxt
-         [(value app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
+         [(value tail app) (bump sc 1) `(foreign (,conv* ...) ,name ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
          [(effect test) (cp0 `(seq ,e ,true-rec) ctxt env sc wd #f moi)])]
       [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type)
        (context-case ctxt
-         [(value app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
+         [(value tail app) (bump sc 1) `(fcallable (,conv* ...) ,(cp0 e 'value env sc wd #f moi) (,arg-type* ...) ,result-type)]
          [(effect) (cp0 e 'effect env sc wd #f moi)]
          [(test) (make-seq ctxt (cp0 e 'effect env sc wd #f moi) true-rec)])]
       [(record ,rtd ,rtd-expr ,e* ...)
        (context-case ctxt
-         [(value app)
+         [(value tail app)
           (let ([rtd-expr (cp0 rtd-expr 'value env sc wd #f moi)]
                 [e* (map (lambda (e) (cp0 e 'value env sc wd #f moi)) e*)])
             (or (nanopass-case (Lsrc Expr) (result-exp rtd-expr)
@@ -4728,7 +4777,7 @@
        (fluid-let ([likely-to-be-compiled? ltbc?]
                    [opending-list '()]
                    [cp0-info-hashtable (make-weak-eq-hashtable)])
-         (cp0 x 'value empty-env (new-scorer) (new-watchdog) #f #f))]))))
+         (cp0 x 'tail empty-env (new-scorer) (new-watchdog) #f #f))]))))
 
 ; check to make sure all required handlers were seen, after expansion of the
 ; expression above has been completed
diff --git a/s/primdata.ss b/s/primdata.ss
index 244c957bd3..b78b1180de 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -1674,7 +1674,7 @@
   (top-level-mutable? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard])
   (top-level-syntax [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard])
   (top-level-syntax? [sig [(symbol) (symbol environment) -> (boolean)]] [flags discard])
-  (top-level-value [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard])
+  (top-level-value [sig [(symbol) (symbol environment) -> (ptr)]] [flags discard single-valued])
   (transcoder? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (transcript-cafe [sig [(pathname) -> (ptr ...)]] [flags])
   (transcript-off [sig [() -> (void)]] [flags true ieee r5rs])
@@ -2218,8 +2218,8 @@
   ($tlc-ht [flags mifoldable discard])
   ($tlc-keyval [flags pure mifoldable discard])
   ($tlc-next [flags mifoldable discard])
-  ($top-level-bound? [flags discard])
-  ($top-level-value [flags discard cp02])
+  ($top-level-bound? [flags discard single-valued])
+  ($top-level-value [flags discard cp02 single-valued])
   ($trace-closure [flags pure alloc])
   ($trace [flags])
   ($track-dynamic-closure-counts [flags])      ; added for closure instrumentation
diff --git a/s/syntax.ss b/s/syntax.ss
index 239bb23d67..fb8cb2c855 100644
--- a/s/syntax.ss
+++ b/s/syntax.ss
@@ -8757,7 +8757,7 @@
                              ;; but tell `$foreign-procedure` that the result is actually an & form
                              #`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))]
                             [else
-                             #`(values #,(datum->syntax #'foreign-procedure result-type))])])]
+                             #`(begin #,(datum->syntax #'foreign-procedure result-type))])])]
                       [([extra ...] [extra-arg ...] [extra-check ...])
                        ;; When the result type is `(& <ftype>)`, the `$foreign-procedure` result
                        ;; expects an extra argument as a `(* <ftype>)` that it uses to store the