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.
69 lines
2.5 KiB
Scheme
69 lines
2.5 KiB
Scheme
;;; Continuation-passing style (CPS) intermediate language (IL)
|
|
|
|
;; Copyright (C) 2016, 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 to add "handle-interrupts" primcalls before calls, loop
|
|
;;; back-edges, and returns.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language cps handle-interrupts)
|
|
#: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)
|
|
#:use-module (language cps renumber)
|
|
#:export (add-handle-interrupts))
|
|
|
|
(define (compute-safepoints cps)
|
|
(define (visit-cont label cont safepoints)
|
|
(match cont
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(let ((safepoints (if (<= k label)
|
|
(intset-add! safepoints k)
|
|
safepoints)))
|
|
(if (match exp
|
|
(($ $call) #t)
|
|
(($ $callk) #t)
|
|
(($ $values)
|
|
(match (intmap-ref cps k)
|
|
(($ $ktail) #t)
|
|
(_ #f)))
|
|
(_ #f))
|
|
(intset-add! safepoints label)
|
|
safepoints)))
|
|
(_ safepoints)))
|
|
(persistent-intset (intmap-fold visit-cont cps empty-intset)))
|
|
|
|
(define (add-handle-interrupts cps)
|
|
(define (add-safepoint label cps)
|
|
(match (intmap-ref cps label)
|
|
(($ $kargs names vars ($ $continue k src exp))
|
|
(with-cps cps
|
|
(letk k* ($kargs () () ($continue k src ,exp)))
|
|
(setk label
|
|
($kargs names vars
|
|
($continue k* src
|
|
($primcall 'handle-interrupts #f ()))))))))
|
|
(let* ((cps (renumber cps))
|
|
(safepoints (compute-safepoints cps)))
|
|
(with-fresh-name-state cps
|
|
(persistent-intmap (intset-fold add-safepoint safepoints cps)))))
|