Merge branch 'sv' of github.com:mflatt/ChezScheme

original commit: 9dd62e2d4a44879ddb210bb6ebe7ad600b832634

LOG

@@ -1055,3 +1055,10 @@
     inspect.ss, bitset.ss, cmacros.ss, prims.ss, primdata.ss, Mf-base,
     prim.c, types.h, misc.ms, thread.ms, debug.stex, threads.stex,
     release_notes.stex
+- adjust compiler, especially cp0, to avoid turning errors like `(let
+  ([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/cmacros.ss

@@ -1614,8 +1614,8 @@
   (simple                        #b0000100000)
   (boolean-valued-known          #b0001000000)
   (boolean-valued                #b0010000000)
-  (single-valued-nontail-known   #b0100000000)
+  (single-valued-known           #b0100000000)
-  (single-valued-nontail         #b1000000000)
+  (single-valued                 #b1000000000)
 )
 
 (define-syntax define-flag-field

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]
@@ -1219,17 +1246,26 @@
 
       (define-who single-valued?
         (lambda (e)
-          (with-memoize (single-valued-nontail-known single-valued-nontail) e
+          (with-memoize (single-valued-known single-valued) e
             ; known to produce a single value
             (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)))]