diff --git a/am/bootstrap.am b/am/bootstrap.am
index 51992721f..2821304ec 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 9cb8fcedd..11a35c2cb 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 7d2c9b668..d214987b3 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 a40d466bd..35ee0ccb9 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 031b0cd13..664c4b305 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 d9e883c4f..7315fce73 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 a32b7b456..8be36c84d 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 632b2cac1..1a2305ed4 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 4515915c7..b44c1e78c 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 000000000..c600d11ab
--- /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 6364b703b..db52956e7 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 e1f5e3a78..c72c04434 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 6a88d7ecd..cf40cb8a2 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.