mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-17 22:42:25 +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.
106 lines
3.7 KiB
Scheme
106 lines
3.7 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:
|
|
;;;
|
|
;;; Constructor inlining turns "list" primcalls into a series of conses,
|
|
;;; and does similar transformations for "vector".
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define-module (language cps constructors)
|
|
#: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 (inline-constructors))
|
|
|
|
(define (inline-list out k src args)
|
|
(define (build-list out args k)
|
|
(match args
|
|
(()
|
|
(with-cps out
|
|
(build-term ($continue k src ($const '())))))
|
|
((arg . args)
|
|
(with-cps out
|
|
(letv tail)
|
|
(letk ktail ($kargs ('tail) (tail)
|
|
($continue k src
|
|
($primcall 'cons #f (arg tail)))))
|
|
($ (build-list args ktail))))))
|
|
(with-cps out
|
|
(letv val)
|
|
(letk kvalues ($kargs ('val) (val)
|
|
($continue k src
|
|
($primcall 'values #f (val)))))
|
|
($ (build-list args kvalues))))
|
|
|
|
(define (inline-vector out k src args)
|
|
(define (initialize out vec args n)
|
|
(match args
|
|
(()
|
|
(with-cps out
|
|
(build-term ($continue k src ($primcall 'values #f (vec))))))
|
|
((arg . args)
|
|
(with-cps out
|
|
(let$ next (initialize vec args (1+ n)))
|
|
(letk knext ($kargs () () ,next))
|
|
(letv u64)
|
|
(letk kunbox ($kargs ('idx) (u64)
|
|
($continue knext src
|
|
($primcall 'vector-set! #f (vec u64 arg)))))
|
|
($ (with-cps-constants ((idx n))
|
|
(build-term ($continue kunbox src
|
|
($primcall 'scm->u64 #f (idx))))))))))
|
|
(with-cps out
|
|
(letv vec)
|
|
(let$ body (initialize vec args 0))
|
|
(letk kalloc ($kargs ('vec) (vec) ,body))
|
|
($ (with-cps-constants ((len (length args))
|
|
(init #f))
|
|
(letv u64)
|
|
(letk kunbox ($kargs ('len) (u64)
|
|
($continue kalloc src
|
|
($primcall 'make-vector #f (u64 init)))))
|
|
(build-term ($continue kunbox src
|
|
($primcall 'scm->u64 #f (len))))))))
|
|
|
|
(define (find-constructor-inliner name)
|
|
(match name
|
|
('list inline-list)
|
|
('vector inline-vector)
|
|
(_ #f)))
|
|
|
|
(define (inline-constructors conts)
|
|
(with-fresh-name-state conts
|
|
(persistent-intmap
|
|
(intmap-fold
|
|
(lambda (label cont out)
|
|
(match cont
|
|
(($ $kargs names vars ($ $continue k src ($ $primcall name #f args)))
|
|
(let ((inline (find-constructor-inliner name)))
|
|
(if inline
|
|
(call-with-values (lambda () (inline out k src args))
|
|
(lambda (out term)
|
|
(intmap-replace! out label
|
|
(build-cont ($kargs names vars ,term)))))
|
|
out)))
|
|
(_ out)))
|
|
conts
|
|
conts))))
|