[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/04: Add new pass to optimize branch chains to table d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/04: Add new pass to optimize branch chains to table dispatch |
|
Date: |
Wed, 12 Aug 2020 17:32:28 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 03998db647546df017feb19c0d5912e7451a61fc
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Aug 11 23:09:51 2020 +0200
Add new pass to optimize branch chains to table dispatch
* 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.
---
am/bootstrap.am | 1 +
libguile/hash.c | 4 +
module/Makefile.am | 1 +
module/language/cps/closure-conversion.scm | 40 +--
module/language/cps/contification.scm | 31 ---
module/language/cps/effects-analysis.scm | 2 +
module/language/cps/graphs.scm | 7 +
module/language/cps/optimize.scm | 2 +
module/language/cps/simplify.scm | 38 +--
module/language/cps/switch.scm | 424 +++++++++++++++++++++++++++++
module/language/cps/types.scm | 1 +
module/language/cps/utils.scm | 34 +++
module/system/base/optimize.scm | 1 +
13 files changed, 488 insertions(+), 98 deletions(-)
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 5199272..2821304 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -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 \
diff --git a/libguile/hash.c b/libguile/hash.c
index 9cb8fce..11a35c2 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -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 \
diff --git a/module/Makefile.am b/module/Makefile.am
index 7d2c9b6..d214987 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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 \
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index a40d466..35ee0cc 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -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))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 031b0cd..664c4b3 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -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
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index d9e883c..7315fce 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -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)
diff --git a/module/language/cps/graphs.scm b/module/language/cps/graphs.scm
index a32b7b4..8be36c8 100644
--- a/module/language/cps/graphs.scm
+++ b/module/language/cps/graphs.scm
@@ -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)
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 632b2ca..1a2305e 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -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?)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 4515915..b44c1e7 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -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)
diff --git a/module/language/cps/switch.scm b/module/language/cps/switch.scm
new file mode 100644
index 0000000..c600d11
--- /dev/null
+++ b/module/language/cps/switch.scm
@@ -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))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 6364b70..db52956 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -739,6 +739,7 @@ minimum, and maximum."
('vector &vector)
('string &string)
('stringbuf &string)
+ ('symbol &symbol)
('bytevector &bytevector)
('box &box)
('closure &procedure)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index e1f5e3a..c72c044 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -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
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
index 6a88d7e..cf40cb8 100644
--- a/module/system/base/optimize.scm
+++ b/module/system/base/optimize.scm
@@ -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.