diff options
Diffstat (limited to 'module/language/cps/elide-values.scm')
-rw-r--r-- | module/language/cps/elide-values.scm | 88 |
1 files changed, 0 insertions, 88 deletions
diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm deleted file mode 100644 index 81ccfc200..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 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 (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 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)))) |