mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-18 18:40:22 +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.
86 lines
3.1 KiB
Scheme
86 lines
3.1 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:
|
|
;;;
|
|
;;; A pass that prunes successors of expressions that bail out.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language cps prune-bailouts)
|
|
#: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)
|
|
#:use-module (language cps intset)
|
|
#:export (prune-bailouts))
|
|
|
|
(define (compute-tails conts)
|
|
"For each LABEL->CONT entry in the intmap CONTS, compute a
|
|
LABEL->TAIL-LABEL indicating the tail continuation of each expression's
|
|
containing function. In some cases TAIL-LABEL might not be available,
|
|
for example if there is a stale $kfun pointing at a body, or for
|
|
unreferenced terms. In that case TAIL-LABEL is either absent or #f."
|
|
(intmap-fold
|
|
(lambda (label cont out)
|
|
(match cont
|
|
(($ $kfun src meta self tail clause)
|
|
(intset-fold (lambda (label out)
|
|
(intmap-add out label tail (lambda (old new) #f)))
|
|
(compute-function-body conts label)
|
|
out))
|
|
(_ out)))
|
|
conts
|
|
empty-intmap))
|
|
|
|
(define (prune-bailout out tails k src exp)
|
|
(match (intmap-ref out k)
|
|
(($ $ktail)
|
|
(with-cps out #f))
|
|
(_
|
|
(match (intmap-ref tails k (lambda (_) #f))
|
|
(#f
|
|
(with-cps out #f))
|
|
(ktail
|
|
(with-cps out
|
|
(letv prim rest)
|
|
(letk kresult ($kargs ('rest) (rest)
|
|
($continue ktail src ($values ()))))
|
|
(letk kreceive ($kreceive '() 'rest kresult))
|
|
(build-term ($continue kreceive src ,exp))))))))
|
|
|
|
(define (prune-bailouts conts)
|
|
(let ((tails (compute-tails conts)))
|
|
(with-fresh-name-state conts
|
|
(persistent-intmap
|
|
(intmap-fold
|
|
(lambda (label cont out)
|
|
(match cont
|
|
(($ $kargs names vars
|
|
($ $continue k src
|
|
(and exp ($ $primcall (or 'error 'scm-error 'throw)))))
|
|
(call-with-values (lambda () (prune-bailout out tails k src exp))
|
|
(lambda (out term)
|
|
(if term
|
|
(let ((cont (build-cont ($kargs names vars ,term))))
|
|
(intmap-replace! out label cont))
|
|
out))))
|
|
(_ out)))
|
|
conts
|
|
conts)))))
|