Inline "elide-values" optimization into CPS conversion

* module/language/tree-il/compile-cps.scm (adapt-arity, convert): Avoid
  reifying "values" primcalls unless necessary.  Effectively inlines the
  "elide-values" optimization into CPS conversion.
* module/language/cps/elide-values.scm: Remove, as it's now unneeded.
* module/language/cps/optimize.scm (optimize-higher-order-cps):
* module/Makefile.am:
* am/bootstrap.am: Remove elide-values references.

am/bootstrap.am

@@ -82,7 +82,6 @@ SOURCES =					\
   language/cps/dce.scm				\
   language/cps/devirtualize-integers.scm	\
   language/cps/effects-analysis.scm		\
-  language/cps/elide-values.scm			\
   language/cps/handle-interrupts.scm		\
   language/cps/licm.scm				\
   language/cps/peel-loops.scm			\

module/Makefile.am

@@ -137,7 +137,6 @@ SOURCES =					\
   language/cps/dce.scm				\
   language/cps/devirtualize-integers.scm	\
   language/cps/effects-analysis.scm		\
-  language/cps/elide-values.scm			\
   language/cps/handle-interrupts.scm		\
   language/cps/intmap.scm			\
   language/cps/intset.scm			\

module/language/cps/elide-values.scm

@@ -1,88 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Commentary:
-;;;
-;;; Primcalls that don't correspond to VM instructions are treated as if
-;;; they are calls, and indeed the later reify-primitives pass turns
-;;; them into calls.  Because no return arity checking is done for these
-;;; primitives, if a later optimization pass simplifies the primcall to
-;;; a VM operation, the tail of the simplification has to be a
-;;; primcall to 'values.  Most of these primcalls can be elided, and
-;;; that is the job of this pass.
-;;;
-;;; Code:
-
-(define-module (language cps elide-values)
-  #:use-module (ice-9 match)
-  #:use-module (language cps)
-  #:use-module (language cps utils)
-  #:use-module (language cps with-cps)
-  #:use-module (language cps intmap)
-  #:export (elide-values))
-
-(define (inline-values cps k src args)
-  (match (intmap-ref cps k)
-    (($ $ktail)
-     (with-cps cps
-       (build-term
-         ($continue k src ($values args)))))
-    (($ $kreceive ($ $arity req () rest () #f) kargs)
-     (cond
-      ((and (not rest) (= (length args) (length req)))
-       (with-cps cps
-         (build-term
-           ($continue kargs src ($values args)))))
-      ((and rest (>= (length args) (length req)))
-       (let ()
-         (define (build-rest cps k tail)
-           (match tail
-             (()
-              (with-cps cps
-                (build-term ($continue k src ($const '())))))
-             ((v . tail)
-              (with-cps cps
-                (letv rest)
-                (letk krest ($kargs ('rest) (rest)
-                              ($continue k src ($primcall 'cons #f (v rest)))))
-                ($ (build-rest krest tail))))))
-         (with-cps cps
-           (letv rest)
-           (letk krest ($kargs ('rest) (rest)
-                         ($continue kargs src
-                           ($values ,(append (list-head args (length req))
-                                             (list rest))))))
-           ($ (build-rest krest (list-tail args (length req)))))))
-      (else (with-cps cps #f))))))
-
-(define (elide-values conts)
-  (with-fresh-name-state conts
-    (persistent-intmap
-     (intmap-fold
-      (lambda (label cont out)
-        (match cont
-          (($ $kargs names vars ($ $continue k src ($ $primcall 'values #f args)))
-           (call-with-values (lambda () (inline-values out k src args))
-             (lambda (out term)
-               (if term
-                   (let ((cont (build-cont ($kargs names vars ,term))))
-                     (intmap-replace! out label cont))
-                   out))))
-          (_ out)))
-      conts
-      conts))))

module/language/cps/optimize.scm

@@ -29,7 +29,6 @@
   #:use-module (language cps cse)
   #:use-module (language cps devirtualize-integers)
   #:use-module (language cps dce)
-  #:use-module (language cps elide-values)
   #:use-module (language cps licm)
   #:use-module (language cps peel-loops)
   #:use-module (language cps prune-top-level-scopes)
@@ -95,7 +94,6 @@
   (simplify #:simplify? #t)
   (contify #:contify? #t)
   (inline-constructors #:inline-constructors? #t)
-  (elide-values #:elide-values? #t)
   (prune-bailouts #:prune-bailouts? #t)
   (simplify #:simplify? #t)
   (devirtualize-integers #:devirtualize-integers? #t)
@@ -125,7 +123,6 @@
    #:contify? #t
    #:inline-constructors? #t
    #:specialize-primcalls? #t
-   #:elide-values? #t
    #:prune-bailouts? #t
    #:peel-loops? #t
    #:cse? #t

module/language/tree-il/compile-cps.scm

@@ -314,6 +314,18 @@
                      ($branch kunbound
                               ($primcall 'undefined? #f (orig-var))))))))))))))
 
+(define (build-list cps k src vals)
+  (match vals
+    (()
+     (with-cps cps
+       (build-term ($continue k src ($const '())))))
+    ((v . vals)
+     (with-cps cps
+       (letv tail)
+       (letk ktail ($kargs ('tail) (tail)
+                     ($continue k src ($primcall 'cons #f (v tail)))))
+       ($ (build-list ktail src vals))))))
+
 ;;; The conversion from Tree-IL to CPS essentially wraps every
 ;;; expression in a $kreceive, which models the Tree-IL semantics that
 ;;; extra values are simply truncated.  In CPS, this means that the
@@ -384,12 +396,15 @@
           (_
            ;; Arity mismatch.  Serialize a values call.
            (with-cps cps
+             (letv values)
              (let$ void (with-cps-constants ((unspecified *unspecified*))
                           (build-term
                             ($continue k src
-                              ($primcall 'values #f (unspecified))))))
+                              ($call values (unspecified))))))
-             (letk kvoid ($kargs () () ,void))
+             (letk kvoid ($kargs ('values) (values) ,void))
-             kvoid))))))
+             (letk kvalues ($kargs () ()
+                             ($continue kvoid src ($prim 'values))))
+             kvalues))))))
     (1
      (match (intmap-ref cps k)
        (($ $ktail)
@@ -423,10 +438,12 @@
           (_
            ;; Arity mismatch.  Serialize a values call.
            (with-cps cps
-             (letv val)
+             (letv val values)
+             (letk kvalues ($kargs ('values) (values)
+                             ($continue k src
+                               ($call values (val)))))
              (letk kval ($kargs ('val) (val)
-                          ($continue k src
+                          ($continue kvalues src ($prim 'values))))
-                            ($primcall 'values #f (val)))))
              kval))))))))
 
 ;; cps exp k-name alist -> cps term
@@ -442,6 +459,7 @@
       ;; (($ <fix> src names syms vals body) (zero-valued? body))
       (($ <let-values> src exp body) (zero-valued? body))
       (($ <seq> src head tail) (zero-valued? tail))
+      (($ <primcall> src 'values args) (= (length args) 0))
       (($ <primcall> src name args)
        (match (tree-il-primitive->cps-primitive+nargs+nvalues name)
          (#f #f)
@@ -458,6 +476,7 @@
       (($ <fix> src names syms vals body) (single-valued? body))
       (($ <let-values> src exp body) (single-valued? body))
       (($ <seq> src head tail) (single-valued? tail))
+      (($ <primcall> src 'values args) (= (length args) 1))
       (($ <primcall> src name args)
        (match (tree-il-primitive->cps-primitive+nargs+nvalues name)
          (#f #f)
@@ -669,17 +688,6 @@
      (cond
       ((eq? name 'throw)
        (let ()
-         (define (build-list cps k vals)
-           (match vals
-             (()
-              (with-cps cps
-                (build-term ($continue k src ($const '())))))
-             ((v . vals)
-              (with-cps cps
-                (letv tail)
-                (letk ktail ($kargs ('tail) (tail)
-                              ($continue k src ($primcall 'cons #f (v tail)))))
-                ($ (build-list ktail vals))))))
          (define (fallback)
            (convert-args cps args
              (lambda (cps args)
@@ -691,7 +699,7 @@
                     (letk kargs ($kargs ('arglist) (arglist)
                                   ($continue k src
                                     ($primcall 'throw #f (key arglist)))))
-                    ($ (build-list kargs args))))))))
+                    ($ (build-list kargs src args))))))))
          (define (specialize op param . args)
            (convert-args cps args
              (lambda (cps args)
@@ -712,6 +720,41 @@
                  (specialize 'throw/value `#(,key ,subr ,msg) x))
                 (_ (fallback)))))
            (_ (fallback)))))
+      ((eq? name 'values)
+       (convert-args cps args
+         (lambda (cps args)
+           (match (intmap-ref cps k)
+             (($ $ktail)
+              (with-cps cps
+                (build-term
+                  ($continue k src ($values args)))))
+             (($ $kargs names)
+              ;; Can happen if continuation already saw we produced the
+              ;; right number of values.
+              (with-cps cps
+                (build-term
+                  ($continue k src ($values args)))))
+             (($ $kreceive ($ $arity req () rest () #f) kargs)
+              (cond
+               ((and (not rest) (= (length args) (length req)))
+                (with-cps cps
+                  (build-term
+                    ($continue kargs src ($values args)))))
+               ((and rest (>= (length args) (length req)))
+                (with-cps cps
+                  (letv rest)
+                  (letk krest ($kargs ('rest) (rest)
+                                ($continue kargs src
+                                  ($values ,(append (list-head args (length req))
+                                                    (list rest))))))
+                  ($ (build-list krest src (list-tail args (length req))))))
+               (else
+                ;; Number of values mismatch; reify a values call.
+                (with-cps cps
+                  (letv val values)
+                  (letk kvalues ($kargs ('values) (values)
+                                  ($continue k src ($call values args))))
+                  (build-term ($continue kvalues src ($prim 'values)))))))))))
       ((tree-il-primitive->cps-primitive+nargs+nvalues name)
        =>
        (match-lambda