summaryrefslogtreecommitdiff
path: root/module/language/cps/elide-values.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/elide-values.scm')
-rw-r--r--module/language/cps/elide-values.scm88
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))))