use "single-valued" to simplify some call-with-values patterns

original commit: 0b9d2f0d778789ee9fda8a7249c8d7da329c9bcd

LOG

@@ -1031,3 +1031,6 @@
   ([x (values 1 2)]) x)` into programs that return multiple values
     cp0.ss, cpletrec.ss, cpnanopass, prims.ss, primdata.ss, priminfo.ss,
     primvars.ss, cmacros.ss, syntax.ss, cp0.ms, record.ms
+- use the "single-valued" flag on primitives to simplify certain
+  call-with-values patterns
+    cp0.ss, cp0.ms

mats/cp0.ms

@@ -636,6 +636,40 @@
             (tester))))
       (test2 10))
     11)
+  (test-cp0-expansion
+    '(lambda (x)
+       (call-with-values (lambda () (unbox x)) display))
+    (if (eqv? (optimize-level) 3)
+        '(lambda (x) (#3%display (#3%unbox x)))
+        '(lambda (x) (#2%display (#2%unbox x)))))
+  (test-cp0-expansion
+    '(lambda (x)
+       (call-with-values (lambda () (if x 1 2)) display))
+    (if (eqv? (optimize-level) 3)
+        '(lambda (x) (#3%display (if x 1 2)))
+        '(lambda (x) (#2%display (if x 1 2)))))
+  ; verify optimization of begin0 pattern
+  (test-cp0-expansion
+    '(lambda (x)
+       (call-with-values (lambda ()
+                           (call-with-values (lambda () (unbox x))
+                             (case-lambda
+                               [(x) (values x #f)]
+                               [args (values args #t)])))
+         (lambda (l apply?)
+           (newline)
+           (if apply?
+               (apply values l)
+               l))))
+    (if (eqv? (optimize-level) 3)
+        '(lambda (x)
+           (let ([temp (#3%unbox x)])
+             (#3%newline)
+             temp))
+        '(lambda (x)
+           (let ([temp (#2%unbox x)])
+             (#2%newline)
+             temp))))
 )
 
 (cp0-mat apply-partial-folding

s/cp0.ss

@@ -1182,18 +1182,45 @@
           (and (simple/profile? e)
                (or (fx= (optimize-level) 3) (single-valued? e)))))
 
+      (define (extract-called-procedure pr e*)
+        (case (primref-name pr)
+          [(call-with-values)
+           (and (fx= (length e*) 2)
+                (cadr e*))]
+          [(r6rs:dynamic-wind)
+           (and (fx= (length e*) 3)
+                (cadr e*))]
+          [(dynamic-wind)
+           (cond
+            [(fx= (length e*) 3) (cadr e*)]
+            [(fx= (length e*) 4) (caddr e*)]
+            [else #f])]
+          [(apply $apply)
+           (and (fx>= (length e*) 1)
+                (car e*))]
+          [else #f]))
+
       (define-who boolean-valued?
         (lambda (e)
           (with-memoize (boolean-valued-known boolean-valued) e
             ; 2015/02/11 sorted by frequency
             (nanopass-case (Lsrc Expr) e
               [(call ,preinfo ,e ,e* ...)
-               (nanopass-case (Lsrc Expr) (result-exp e)
+               (let procedure-boolean-valued? ([e e] [e* e*])
-                 [,pr (all-set? (prim-mask boolean-valued) (primref-flags pr))]
+                 (nanopass-case (Lsrc Expr) (result-exp e)
-                 [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
+                   [,pr
-                  (guard (fx= interface (length e*)))
+                    (or (all-set? (prim-mask boolean-valued) (primref-flags pr))
-                  (memoize (boolean-valued? body))]
+                        (and e*
-                 [else #f])]
+                             (let ([proc-e (extract-called-procedure pr e*)])
+                               (and proc-e
+                                    (memoize (procedure-boolean-valued? proc-e #f))))))]
+                   [(case-lambda ,preinfo ,cl* ...)
+                    (memoize (andmap (lambda (cl)
+                                       (nanopass-case (Lsrc CaseLambdaClause) cl
+                                         [(clause (,x* ...) ,interface ,body)
+                                          (boolean-valued? body)]))
+                                     cl*))]
+                   [else #f]))]
               [(if ,e0 ,e1 ,e2) (memoize (and (boolean-valued? e1) (boolean-valued? e2)))]
               [(record-ref ,rtd ,type ,index ,e) (eq? type 'boolean)]
               [(ref ,maybe-src ,x) #f]
@@ -1224,12 +1251,21 @@
             (nanopass-case (Lsrc Expr) e
               [(quote ,d) #t]
               [(call ,preinfo ,e ,e* ...)
-               (nanopass-case (Lsrc Expr) e
+               (let procedure-single-valued? ([e e] [e* e*])
-                 [,pr (all-set? (prim-mask single-valued) (primref-flags pr))]
+                 (nanopass-case (Lsrc Expr) (result-exp e)
-                 [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body))
+                   [,pr
-                  (guard (fx= interface (length e*)))
+                    (or (all-set? (prim-mask single-valued) (primref-flags pr))
-                  (memoize (single-valued? body))]
+                        (and e*
-                 [else #f])]
+                             (let ([proc-e (extract-called-procedure pr e*)])
+                               (and proc-e
+                                    (memoize (procedure-single-valued? proc-e #f))))))]
+                   [(case-lambda ,preinfo ,cl* ...)
+                    (memoize (andmap (lambda (cl)
+                                       (nanopass-case (Lsrc CaseLambdaClause) cl
+                                         [(clause (,x* ...) ,interface ,body)
+                                          (single-valued? body)]))
+                                     cl*))]
+                   [else #f]))]
               [(ref ,maybe-src ,x) #t]
               [(case-lambda ,preinfo ,cl* ...) #t]
               [(if ,e1 ,e2 ,e3) (memoize (and (single-valued? e2) (single-valued? e3)))]