mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-17 11:10:18 +02:00
c54c151eb6
* module/language/cps.scm ($primcall): Add "param" member, which will be a constant parameter to the primcall. The idea is that constants used by primcalls as immediates don't need to participate in optimizations in any way -- they should not participate in CSE, have the same lifetime as the primcall so not part of DCE either, and don't need slot allocation. Indirecting them through a named $const binding is complication for no benefit. This change should eventually improve compilation time and memory usage, once we fully take advantage of it, as the number of labels and variables will go down. * module/language/cps/closure-conversion.scm: * module/language/cps/compile-bytecode.scm: * module/language/cps/constructors.scm: * module/language/cps/contification.scm: * module/language/cps/cse.scm: * module/language/cps/dce.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/elide-values.scm: * module/language/cps/handle-interrupts.scm: * module/language/cps/licm.scm: * module/language/cps/peel-loops.scm: * module/language/cps/prune-bailouts.scm: * module/language/cps/prune-top-level-scopes.scm: * module/language/cps/reify-primitives.scm: * module/language/cps/renumber.scm: * module/language/cps/rotate-loops.scm: * module/language/cps/self-references.scm: * module/language/cps/simplify.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/specialize-numbers.scm: * module/language/cps/specialize-primcalls.scm: * module/language/cps/split-rec.scm: * module/language/cps/type-checks.scm: * module/language/cps/type-fold.scm: * module/language/cps/types.scm: * module/language/cps/utils.scm: * module/language/cps/verify.scm: * module/language/tree-il/compile-cps.scm: Adapt all users.
88 lines
3.4 KiB
Scheme
88 lines
3.4 KiB
Scheme
;;; 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))))
|