mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Add new pass to optimize branch chains to table dispatch

Browse source 
* module/language/cps/switch.scm: New pass.

* module/Makefile.am (SOURCES):
* am/bootstrap.am (SOURCES): Add switch.scm.

* module/system/base/optimize.scm (available-optimizations):
* module/language/cps/optimize.scm (optimize-first-order-cps): Run
  switch optimization at level 2.

* libguile/hash.c (JENKINS_LOOKUP3_HASHWORD2): Add note regarding
  cross-compilation.

* module/language/cps/graphs.scm (intmap-select): New definition.
* module/language/cps/utils.scm (compute-singly-referenced-labels): Move
  here, from various places.  Doesn't take a body intset argument.

* module/language/cps/contification.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/simplify.scm: Use compute-singly-referenced-labels
  from utils.

* module/language/cps/effects-analysis.scm (annotation->memory-kind*):
  (annotation->memory-kind): Add symbol annotation cases.
This commit is contained in:
Andy Wingo 2020-08-11 23:09:51 +02:00
parent cd5ab6377b
commit 03998db647
13 changed files with 488 additions and 98 deletions
Download patch file Download diff file Expand all files Collapse all files

1
am/bootstrap.am
View file

@ -150,6 +150,7 @@ SOURCES = \
language/cps/specialize-primcalls.scm \
language/cps/specialize-numbers.scm \
language/cps/split-rec.scm \
language/cps/switch.scm \
language/cps/type-checks.scm \
language/cps/type-fold.scm \
language/cps/types.scm \

4
libguile/hash.c
View file

@ -110,6 +110,10 @@ extern double floor();
break; \
} \
\
/* Scheme can access symbol-hash, which exposes this value. For \
cross-compilation reasons, we ensure that the high 32 bits of \
the hash on a 64-bit system are equal to the hash on a 32-bit \
system. The low 32 bits just add more entropy. */ \
if (sizeof (ret) == 8) \
ret = (((unsigned long) c) << 32) | b; \
else \

1
module/Makefile.am
View file

@ -71,6 +71,7 @@ SOURCES = \
language/cps/specialize-primcalls.scm \
language/cps/specialize-numbers.scm \
language/cps/split-rec.scm \
language/cps/switch.scm \
language/cps/type-checks.scm \
language/cps/type-fold.scm \
language/cps/types.scm \

40
module/language/cps/closure-conversion.scm
View file

@ -107,35 +107,6 @@ conts."
conts
empty-intset)))
(define (compute-singly-referenced-labels conts body)
(define (add-ref label single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(define (ref* k*) (fold2 ref k* single multiple))
(match (intmap-ref conts label)
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs _ _ ($ $continue k)) (ref1 k))
(($ $kargs _ _ ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs _ _ ($ $switch kf kt*)) (ref* (cons kf kt*)))
(($ $kargs _ _ ($ $prompt k kh)) (ref2 k kh))
(($ $kargs _ _ ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-function-names conts functions)
"Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function
whose bound vars we know."
@ -145,10 +116,11 @@ whose bound vars we know."
(intmap-add out kfun (intset var self))))
(intmap-fold
(lambda (label body out)
(let ((single (compute-singly-referenced-labels conts body)))
(intset-fold
(lambda (label out)
(match (intmap-ref conts label)
(let* ((conts (intmap-select conts body))
(single (compute-singly-referenced-labels conts)))
(intmap-fold
(lambda (label cont out)
(match cont
(($ $kargs _ _ ($ $continue k _ ($ $fun kfun)))
(if (intset-ref single k)
(match (intmap-ref conts k)
@ -160,7 +132,7 @@ whose bound vars we know."
(error "$rec continuation has multiple predecessors??"))
(fold add-named-fun out vars kfun))
(_ out)))
body
conts
out)))
functions
empty-intmap))

31
module/language/cps/contification.scm
View file

@ -40,37 +40,6 @@
#:use-module (language cps with-cps)
#:export (contify))
(define (compute-singly-referenced-labels conts)
"Compute the set of labels in CONTS that have exactly one
predecessor."
(define (add-ref label cont single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match cont
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs names syms ($ $switch kf kt*))
(fold2 ref (cons kf kt*) single multiple))
(($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
(($ $kargs names syms ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-functions conts)
"Compute a map from $kfun label to bound variable names for all
functions in CONTS. Functions have two bound variable names: their self

2
module/language/cps/effects-analysis.scm
View file

@ -351,6 +351,7 @@ the LABELS that are clobbered by the effects of LABEL."
(('string . (or 0 1 2 3)) &header)
(('stringbuf . (or 0 1)) &header)
(('bytevector . (or 0 1 2 3)) &header)
(('symbol . (or 0 1 2)) &header)
(('box . 0) &header)
(('closure . (or 0 1)) &header)
(('struct . 0) &header)
@ -363,6 +364,7 @@ the LABELS that are clobbered by the effects of LABEL."
('vector &vector)
('string &string)
('stringbuf &string)
('symbol &unknown-memory-kinds)
('bytevector &bytevector)
('bitmask &bitmask)
('box &box)

7
module/language/cps/graphs.scm
View file

@ -34,6 +34,7 @@
intmap-keys
invert-bijection invert-partition
intset->intmap
intmap-select
worklist-fold
fixpoint
@ -99,6 +100,12 @@ disjoint, an error will be signalled."
(intmap-add! preds label (f label)))
set empty-intmap)))
(define (intmap-select map set)
(persistent-intmap
(intset-fold (lambda (label out)
(intmap-add! out label (intmap-ref map label)))
set empty-intmap)))
(define worklist-fold
(case-lambda
((f in out)

2
module/language/cps/optimize.scm
View file

@ -40,6 +40,7 @@
#:use-module (language cps specialize-numbers)
#:use-module (language cps specialize-primcalls)
#:use-module (language cps split-rec)
#:use-module (language cps switch)
#:use-module (language cps type-fold)
#:use-module (language cps verify)
#:use-module (system base optimize)
@ -107,6 +108,7 @@
(specialize-primcalls #:specialize-primcalls?)
(eliminate-common-subexpressions #:cse?)
(eliminate-dead-code #:eliminate-dead-code?)
(optimize-branch-chains #:optimize-branch-chains?)
;; Running simplify here enables rotate-loops to do a better job.
(simplify #:simplify?)
(rotate-loops #:rotate-loops?)

38
module/language/cps/simplify.scm
View file

@ -180,40 +180,12 @@
(_ ,cont))))
conts)))
(define (compute-singly-referenced-labels conts body)
(define (add-ref label single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs names syms ($ $switch kf kt*))
(fold2 ref (cons kf kt*) single multiple))
(($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
(($ $kargs names syms ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intset-fold add-ref body single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define (compute-beta-reductions conts kfun)
(define (visit-fun kfun body beta)
(let ((single (compute-singly-referenced-labels conts body)))
(define (visit-cont label beta)
(match (intmap-ref conts label)
(let* ((conts (intmap-select conts body))
(single (compute-singly-referenced-labels conts)))
(define (visit-cont label cont beta)
(match cont
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only
;; be inlined if it is used only once, and not recursively.
@ -225,7 +197,7 @@
(_ #f)))))
(_
beta)))
(intset-fold visit-cont body beta)))
(intmap-fold visit-cont conts beta)))
(persistent-intset
(intmap-fold visit-fun
(compute-reachable-functions conts kfun)

424
module/language/cps/switch.scm Normal file
View file

@ -0,0 +1,424 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2020 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 optimize chains of "eq-constant?" branches.
;;;
;;; For chains that are more than a few comparisons long, we partition
;;; values by type, then dispatch in type-specific ways. For fixnums
;;; and chars, we use a combination of binary search over sparse sets,
;;; table dispatch over dense sets, and comparison chains when sets are
;;; small enough. For "special" values like #f and the eof-object, we
;;; just emit comparison chains. For symbols, we do a hash dispatch
;;; using the hash code from the symbol, or a comparison chain if the
;;; set is very small.
;;;
;;; Code:
(define-module (language cps switch)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#: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 (system base target)
#:export (optimize-branch-chains))
(define (fold-branch-chains cps kfun body f seed)
"For each chain of one or more eq-constant? branches, where each
branch tests the same variable, branches to the next if the match fails,
and each non-head branch has only a single predecessor, fold F over SEED
by calling as (F VAR EXIT TESTS SEED), where VAR is the value being
tested, EXIT is the last failure continuation, and TESTS is an ordered
list of branch labels."
(define single
(compute-singly-referenced-labels (intmap-select cps body)))
(define (start-chain var exit test)
(traverse-chain var exit (list test)))
(define (finish-chain var exit tests)
(values var exit (reverse tests)))
(define (traverse-chain var exit tests)
(match (intmap-ref cps exit)
(($ $kargs () ()
($ $branch kf kt src 'eq-constant? const (arg)))
(if (and (eq? arg var)
(intset-ref single exit))
(traverse-chain var kf (cons exit tests))
(finish-chain var exit tests)))
(_ (finish-chain var exit tests))))
(let fold-chains ((worklist (list kfun))
(visited empty-intset)
(seed seed))
(match worklist
(() seed)
((label . worklist)
(if (intset-ref visited label)
(fold-chains worklist visited seed)
(let ((visited (intset-add! visited label)))
(define (%continue worklist)
(fold-chains worklist visited seed))
(define (continue0) (%continue worklist))
(define (continue1 k) (%continue (cons k worklist)))
(define (continue2 k1 k2) (%continue (cons* k1 k2 worklist)))
(define (continue* k*) (%continue (append k* worklist)))
(match (intmap-ref cps label)
(($ $kfun src meta self ktail #f) (continue0))
(($ $kfun src meta self ktail kclause) (continue1 kclause))
(($ $kclause arity kbody #f) (continue1 kbody))
(($ $kclause arity kbody kalt) (continue2 kbody kalt))
(($ $kargs names vars term)
(match term
(($ $branch kf kt src 'eq-constant? const (arg))
(call-with-values (lambda () (start-chain arg kf label))
(lambda (var exit tests)
(fold-chains (cons exit worklist)
(fold1 (lambda (k visited)
(intset-add! visited k))
tests visited)
(f var exit tests seed)))))
(($ $continue k) (continue1 k))
(($ $branch kf kt) (continue2 kf kt))
(($ $switch kf kt*) (continue* (cons kf kt*)))
(($ $prompt k kh) (continue2 k kh))
(($ $throw) (continue0))))
(($ $ktail) (continue0))
(($ $kreceive arity kbody) (continue1 kbody)))))))))
(define (length>? ls n)
(match ls
(() #f)
((_ . ls)
(or (zero? n)
(length>? ls (1- n))))))
(define (partition-targets targets)
"Partition the list of (CONST . KT) values into five unordered
sub-lists, ignoring duplicates, according to CONST type: fixnums, chars,
\"special\" values, symbols, and other values. A special value is one
of the immediates #f, (), #t, #nil, the EOF object, or the unspecified
object."
(define (hash-table->alist table)
(hash-map->list cons table))
(define (hash-table->sorted-alist table less?)
(sort (hash-table->alist table) (lambda (a b) (less? (car a) (car b)))))
(let ((fixnums (make-hash-table))
(chars (make-hash-table))
(specials (make-hash-table))
(symbols (make-hash-table))
(others (make-hash-table)))
(for-each (match-lambda
((const . k)
(let ((table (cond
((target-fixnum? const) fixnums)
((char? const) chars)
((eq? const #f) specials)
((eq? const '()) specials)
((eq? const #t) specials)
((eq? const #nil) specials)
((eof-object? const) specials)
((unspecified? const) specials)
((symbol? const) symbols)
(else others))))
(unless (hashq-ref table const)
(hashq-set! table const k)))))
targets)
(values (hash-table->sorted-alist fixnums <)
(hash-table->sorted-alist chars char<?)
(hash-table->alist specials)
(hash-table->sorted-alist symbols
(lambda (s1 s2)
(< (symbol-hash s1)
(symbol-hash s2))))
(hash-table->alist others))))
;; Leave any chain this long or less as is.
(define *unoptimized-chain-length* 4)
;; If we are optimizing a subset of targets, any subset this long or
;; less will be reified as a chain of comparisons.
(define *leaf-chain-max-length* 3)
;; If we end up dispatching via type check with an eye to maybe doing
;; binary/table lookup but the set of targets for the type is this long
;; or less, just reify a chain instead of untagging.
(define *tagged-chain-max-length* 2)
;; When deciding whether to dispatch via binary search or via a switch
;; on constants in a range, do a switch if at least this fraction of
;; constants in the range have continuations.
(define *table-switch-minimum-density* 0.5)
;; When deciding whether to dispatch via hash value on a set of symbol
;; targets, reify a branch chain unless there are more than this many
;; targets. Otherwise the cost outweighs the savings.
(define *symbol-hash-dispatch-min-length* 4)
(define (optimize-branch-chain var exit tests cps)
(define (should-optimize? targets)
(define (has-duplicates? targets)
(let ((consts (make-hash-table)))
(or-map (match-lambda
((const . k)
(or (hash-ref consts const)
(begin
(hash-set! consts const #t)
#f))))
targets)))
;; We optimize if there are "enough" targets, or if there are any
;; duplicate targets.
(or (length>? targets *unoptimized-chain-length*)
(has-duplicates? targets)))
(define (reify-chain cps var targets op k)
(match targets
(() (with-cps cps k))
(((const . kt) . targets)
(with-cps cps
(let$ ktail (reify-chain var targets op k))
(letk khead ($kargs () ()
($branch ktail kt #f op const (var))))
khead))))
(define (reify-switch cps var targets min max exit)
(cond
((zero? min)
(let ((kt* (make-vector (1+ max) exit)))
(for-each (match-lambda
((target . k) (vector-set! kt* target k)))
targets)
(with-cps cps
(letv u64)
(letk kswitch ($kargs ('u64) (u64)
($switch exit (vector->list kt*) #f u64)))
(letk kcvt
($kargs () ()
($continue kswitch #f ($primcall 's64->u64 #f (var)))))
kcvt)))
(else
(let ((targets (map (match-lambda
((target . k) (cons (- target min) k)))
targets))
(op (if (positive? min) 'ssub/immediate 'sadd/immediate)))
(with-cps cps
(letv idx)
(let$ kcvt (reify-switch idx targets 0 (- max min) exit))
(letk kzero ($kargs ('idx) (idx)
($continue kcvt #f ($values ()))))
(letk ksub
($kargs () ()
($continue kzero #f ($primcall op (abs min) (var)))))
ksub)))))
(define (dispatch-numerics cps var targets start end exit)
;; Precondition: VAR is an s64, START < END, and TARGETS hold the
;; untagged values.
(define (value-at idx)
(match (vector-ref targets idx)
((const . k) const)))
(define (target-list)
(let lp ((i start))
(if (< i end)
(cons (vector-ref targets i) (lp (1+ i)))
'())))
(let* ((min (value-at start))
(max (value-at (1- end)))
(range (1+ (- max min)))
(len (- end start))
(density (/ len 1.0 range)))
(cond
((<= len *leaf-chain-max-length*)
(reify-chain cps var (target-list) 's64-imm-= exit))
((<= *table-switch-minimum-density* density)
(reify-switch cps var (target-list) min max exit))
(else
;; binary search
(let* ((split (ash (+ start end) -1))
(mid (value-at split)))
(with-cps cps
(let$ klo (dispatch-numerics var targets start split exit))
(let$ khi (dispatch-numerics var targets split end exit))
(letk ktest
($kargs () ()
($branch khi klo #f 's64-imm-< mid (var))))
ktest))))))
(define (reify-known-numerics cps var targets untag-var untag-val exit)
(cond
((length>? targets *tagged-chain-max-length*)
(let ((targets (list->vector
(map (match-lambda
((const . k) (cons (untag-val const) k)))
targets))))
(with-cps cps
(letv raw)
(let$ kdispatch
(dispatch-numerics raw targets 0 (vector-length targets) exit))
(letk kraw ($kargs ('raw) (raw)
($continue kdispatch #f ($values ()))))
(let$ untag (untag-var var kraw))
(letk kuntag ($kargs () () ,untag))
kuntag)))
(else
(reify-chain cps var targets 'eq-constant? exit))))
(define (reify-numeric cps var targets pred untag-var untag-val next exit)
(cond
((null? targets) (with-cps cps next))
(else
(with-cps cps
(let$ ktype (reify-known-numerics var targets untag-var untag-val exit))
(letk test ($kargs () () ($branch next ktype #f pred #f (var))))
test))))
(define (reify-fixnums cps var targets next exit)
(reify-numeric cps var targets 'fixnum?
(lambda (cps var k)
(with-cps cps
(build-term
($continue k #f
($primcall 'untag-fixnum #f (var))))))
identity next exit))
(define (reify-chars cps var targets next exit)
(reify-numeric cps var targets 'char?
(lambda (cps var k)
(with-cps cps
(letv u64)
(letk kcvt
($kargs ('u64) (u64)
($continue k #f
($primcall 'u64->s64 #f (u64)))))
(build-term
($continue kcvt #f
($primcall 'untag-char #f (var))))))
char->integer next exit))
(define (reify-specials cps var targets next exit)
;; Specials are a branch chain.
(cond
((null? targets) (with-cps cps next))
(else
(with-cps cps
(let$ kimm (reify-chain var targets 'eq-constant? exit))
(letk test ($kargs () () ($branch kimm next #f 'heap-object? #f (var))))
test))))
(define (reify-symbols cps var targets next exit)
(cond
((null? targets)
(with-cps cps next))
((length>? targets *symbol-hash-dispatch-min-length*)
;; Hash dispatch. Targets already sorted by symbol-hash. The
;; symbol-hash accessor returns the hash of a symbol, which is the
;; hash of its associated stringbuf. The high 32 bits of the hash
;; on a 64-bit platform are equivalent to the hash on a 32-bit
;; platform. The top two bits are zero, to ensure that hash
;; values can be represented as fixnums. We therefore dispatch on
;; the top N bits, skipping 2 bits, where N <= 30, for the
;; smallest N for which len(targets) <= 2^N.
(let* ((nbits (let ((ntargets (length targets)))
(let lp ((nbits 2))
(if (<= ntargets (ash 1 nbits))
nbits
(lp (1+ nbits))))))
(host-shift (- (* (with-native-target target-word-size) 8) 2 nbits))
(target-shift (- (* (target-word-size) 8) 2 nbits))
(nbuckets (ash 1 nbits))
(buckets (make-vector nbuckets '()))
(kt* (make-vector nbuckets exit)))
(define (next-targets targets next-bucket)
(let lp ((out '()) (targets targets))
(match targets
(() (values out targets))
(((sym . k) . targets*)
(if (< (symbol-hash sym) next-bucket)
(lp (acons sym k out) targets*)
(values out targets))))))
(let lp ((cps cps) (i 0) (targets targets))
(cond
((< i nbuckets)
(call-with-values (lambda ()
(next-targets targets (ash (1+ i) host-shift)))
(lambda (bucket targets)
(call-with-values
(lambda ()
(reify-chain cps var bucket 'eq-constant? exit))
(lambda (cps k)
(vector-set! kt* i k)
(lp cps (1+ i) targets))))))
(else
(with-cps cps
(letv hash idx)
(letk kswitch
($kargs ('idx) (idx)
($switch exit (vector->list kt*) #f idx)))
(letk kidx
($kargs ('hash) (hash)
($continue kswitch #f
($primcall 'ursh/immediate target-shift (hash)))))
(letk khash
($kargs () ()
($continue kidx #f
($primcall 'word-ref/immediate '(symbol . 2) (var)))))
(letk ksym
($kargs () ()
($branch next khash #f 'symbol? #f (var))))
(letk kheap
($kargs () ()
($branch next ksym #f 'heap-object? #f (var))))
kheap))))))
(else
(reify-chain cps var targets 'eq-constant? next))))
(define (reify-others cps var targets exit)
;; Not an immediate, not a symbol -- an object without identity.
;; Perhaps it's reasonable to assume all these don't match.
(reify-chain cps var targets 'eq-constant? exit))
(define (apply-optimizations var exit tests targets)
(call-with-values (lambda () (partition-targets targets))
(lambda (fixnums chars specials symbols others)
(match (intmap-ref cps (car tests))
(($ $kargs names vars _)
(with-cps cps
;; Reify an optimized version of the chain, and bind k to
;; its label.
(let$ k (reify-others var others exit))
(let$ k (reify-symbols var symbols k exit))
(let$ k (reify-specials var specials k exit))
(let$ k (reify-chars var chars k exit))
(let$ k (reify-fixnums var fixnums k exit))
(setk (car tests)
;; Here we introduce a useless forwarding node in
;; order to treat each node as being a nullary
;; $kargs. Simplification will remove it later.
($kargs names vars
($continue k #f ($values ()))))))))))
(let ((targets (map (lambda (test)
(match (intmap-ref cps test)
(($ $kargs _ _ ($ $branch kf kt src op const (_)))
(cons const kt))))
tests)))
(if (should-optimize? targets)
(apply-optimizations var exit tests targets)
cps)))
(define (optimize-branch-chains cps)
(with-fresh-name-state cps
(persistent-intmap
(intmap-fold
(lambda (kfun body cps)
(fold-branch-chains cps kfun body
optimize-branch-chain cps))
(compute-reachable-functions cps)
cps))))

1
module/language/cps/types.scm
View file

@ -739,6 +739,7 @@ minimum, and maximum."
('vector &vector)
('string &string)
('stringbuf &string)
('symbol &symbol)
('bytevector &bytevector)
('box &box)
('closure &procedure)

34
module/language/cps/utils.scm
View file

@ -25,6 +25,7 @@
(define-module (language cps utils)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (language cps)
#:use-module (language cps intset)
#:use-module (language cps intmap)
@ -37,6 +38,7 @@
;; Graphs.
compute-function-body
compute-singly-referenced-labels
compute-reachable-functions
compute-successors
compute-predecessors
@ -48,6 +50,7 @@
intmap-keys
invert-bijection invert-partition
intset->intmap
intmap-select
worklist-fold
fixpoint
@ -129,6 +132,37 @@
(($ $throw)
labels))))))))))
(define (compute-singly-referenced-labels conts)
"Compute the set of labels in CONTS that have exactly one
predecessor."
(define (add-ref label cont single multiple)
(define (ref k single multiple)
(if (intset-ref single k)
(values single (intset-add! multiple k))
(values (intset-add! single k) multiple)))
(define (ref0) (values single multiple))
(define (ref1 k) (ref k single multiple))
(define (ref2 k k*)
(if k*
(let-values (((single multiple) (ref k single multiple)))
(ref k* single multiple))
(ref1 k)))
(match cont
(($ $kreceive arity k) (ref1 k))
(($ $kfun src meta self ktail kclause) (ref2 ktail kclause))
(($ $ktail) (ref0))
(($ $kclause arity kbody kalt) (ref2 kbody kalt))
(($ $kargs names syms ($ $continue k)) (ref1 k))
(($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt))
(($ $kargs names syms ($ $switch kf kt*))
(fold2 ref (cons kf kt*) single multiple))
(($ $kargs names syms ($ $prompt k kh)) (ref2 k kh))
(($ $kargs names syms ($ $throw)) (ref0))))
(let*-values (((single multiple) (values empty-intset empty-intset))
((single multiple) (intmap-fold add-ref conts single multiple)))
(intset-subtract (persistent-intset single)
(persistent-intset multiple))))
(define* (compute-reachable-functions conts #:optional (kfun 0))
"Compute a mapping LABEL->LABEL..., where each key is a reachable
$kfun and each associated value is the body of the function, as an

1
module/system/base/optimize.scm
View file

@ -47,6 +47,7 @@
(#:resolve-self-references? 2)
(#:devirtualize-integers? 2)
(#:specialize-numbers? 2)
(#:optimize-branch-chains? 2)
(#:licm? 2)
(#:rotate-loops? 2)
;; This one is used by the slot allocator.