diff --git a/am/bootstrap.am b/am/bootstrap.am index 8e83e518b..1fd9bfcd4 100644 --- a/am/bootstrap.am +++ b/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 \ diff --git a/module/Makefile.am b/module/Makefile.am index e1ff9f643..4a9c4f18c 100644 --- a/module/Makefile.am +++ b/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 \ diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm deleted file mode 100644 index c0c91c550..000000000 --- a/module/language/cps/elide-values.scm +++ /dev/null @@ -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)))) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 56bc7c186..afd21a5ab 100644 --- a/module/language/cps/optimize.scm +++ b/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 diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 3b2d93ee0..843c9e395 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/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)))))) - (letk kvoid ($kargs () () ,void)) - kvoid)))))) + ($call values (unspecified)))))) + (letk kvoid ($kargs ('values) (values) ,void)) + (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 - ($primcall 'values #f (val))))) + ($continue kvalues src ($prim 'values)))) kval)))))))) ;; cps exp k-name alist -> cps term @@ -442,6 +459,7 @@ ;; (($ src names syms vals body) (zero-valued? body)) (($ src exp body) (zero-valued? body)) (($ src head tail) (zero-valued? tail)) + (($ src 'values args) (= (length args) 0)) (($ src name args) (match (tree-il-primitive->cps-primitive+nargs+nvalues name) (#f #f) @@ -458,6 +476,7 @@ (($ src names syms vals body) (single-valued? body)) (($ src exp body) (single-valued? body)) (($ src head tail) (single-valued? tail)) + (($ src 'values args) (= (length args) 1)) (($ 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