Add $switch CPS term kind

* module/language/cps.scm ($switch): New term.
* doc/ref/compiler.texi (CPS in Guile): Add documentation.

* module/language/cps.scm (build-term, parse-cps, unparse-cps)
* module/language/cps/closure-conversion.scm (compute-non-operator-uses)
  (compute-singly-referenced-labels, rewrite-shared-closure-calls)
  (compute-free-vars, convert-one)
* module/language/cps/compile-bytecode.scm (compile-function)
* module/language/cps/contification.scm (compute-singly-referenced-labels)
  (compute-contification-candidates, apply-contification)
* module/language/cps/cse.scm (compute-truthy-expressions)
  (forward-cont, term-successors, eliminate-common-subexpressions-in-fun)
* module/language/cps/dce.scm (compute-known-allocations)
  (compute-live-code, process-eliminations)
* module/language/cps/devirtualize-integers.scm (compute-use-counts)
  (peel-trace)
* module/language/cps/effects-analysis.scm (compute-effects)
* module/language/cps/licm.scm (hoist-one, hoist-in-loop)
* module/language/cps/loop-instrumentation.scm (compute-loop-headers)
* module/language/cps/peel-loops.scm (rename-cont)
* module/language/cps/renumber.scm (sort-labels-locally, renumber)
* module/language/cps/rotate-loops.scm (rotate-loop)
  (rotate-loops-in-function)
* module/language/cps/self-references.scm (resolve-self-references)
* module/language/cps/simplify.scm (compute-singly-referenced-vars)
  (eta-reduce, compute-singly-referenced-labels, beta-reduce)
* module/language/cps/slot-allocation.scm (compute-defs-and-uses)
  (add-prompt-control-flow-edges, compute-var-representations)
* module/language/cps/specialize-numbers.scm (compute-significant-bits)
* module/language/cps/split-rec.scm (compute-free-vars)
* module/language/cps/type-fold.scm (local-type-fold)
* module/language/cps/types.scm (successor-count, infer-types)
* module/language/cps/utils.scm (compute-function-body)
  (compute-successors, compute-predecessors)
* module/language/cps/verify.scm (compute-available-definitions)
  (check-valid-var-uses, check-arities): Add support for new term.

.dir-locals.el

@@ -40,6 +40,7 @@
      (eval . (put '$letconst           'scheme-indent-function 1))
      (eval . (put '$continue           'scheme-indent-function 2))
      (eval . (put '$branch             'scheme-indent-function 3))
+     (eval . (put '$switch             'scheme-indent-function 3))
      (eval . (put '$prompt             'scheme-indent-function 3))
      (eval . (put '$kargs              'scheme-indent-function 2))
      (eval . (put '$kfun               'scheme-indent-function 4))

doc/ref/compiler.texi

@@ -820,8 +820,8 @@ call target at run-time.
 
 To summarize: a @code{$continue} is a CPS term that continues to a
 single label.  But there are other kinds of CPS terms that can continue
-to a different number of labels: @code{$branch}, @code{$throw}, and
+to a different number of labels: @code{$branch}, @code{$switch},
-@code{$prompt}.
+@code{$throw}, and @code{$prompt}.
 
 @deftp {CPS Term} $branch kf kt src op param args
 Evaluate the branching primcall @var{op}, with arguments @var{args} and
@@ -840,6 +840,19 @@ a test expression to a variable, and then make a @code{$branch} on a
 the branch if possible.
 @end deftp
 
+@deftp {CPS Term} $switch kf kt* src arg
+Continue to a label in the list @var{k*} according to the index argument
+@var{arg}, or to the default continuation @var{kf} if @var{arg} is
+greater than or equal to the length @var{k*}.  The index variable
+@var{arg} is an unboxed, unsigned 64-bit value.
+
+The @code{$switch} term is like C's @code{switch} statement.  The
+compiler to CPS can generate a @code{$switch} term directly, if the
+source language has such a concept, or it can rely on the CPS optimizer
+to turn appropriate chains of @code{$branch} statements to
+@code{$switch} instances, which is what the Scheme compiler does.
+@end deftp
+
 @deftp {CPS Term} $throw src op param args
 Throw a non-resumable exception.  Throw terms do not continue at all.
 The usual value of @var{op} is @code{throw}, with two arguments
@@ -967,6 +980,7 @@ below for full details.
 @deffnx {Scheme Syntax} build-exp ($prompt escape? tag handler)
 @deffnx {Scheme Syntax} build-term ($branch kf kt src op param (arg ...))
 @deffnx {Scheme Syntax} build-term ($branch kf kt src op param args)
+@deffnx {Scheme Syntax} build-term ($switch kf kt* src arg)
 @deffnx {Scheme Syntax} build-term ($throw src op param (arg ...))
 @deffnx {Scheme Syntax} build-term ($throw src op param args)
 @deffnx {Scheme Syntax} build-term ($prompt k kh src escape? tag)

module/language/cps.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-2018,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
@@ -127,7 +127,7 @@
             $kreceive $kargs $kfun $ktail $kclause
 
             ;; Terms.
-            $continue $branch $prompt $throw
+            $continue $branch $switch $prompt $throw
 
             ;; Expressions.
             $const $prim $fun $rec $const-fun $code
@@ -180,6 +180,7 @@
 ;; Terms.
 (define-cps-type $continue k src exp)
 (define-cps-type $branch kf kt src op param args)
+(define-cps-type $switch kf kt* src arg)
 (define-cps-type $prompt k kh src escape? tag)
 (define-cps-type $throw src op param args)
 
@@ -221,7 +222,7 @@
      (make-$kclause (build-arity arity) kbody kalternate))))
 
 (define-syntax build-term
-  (syntax-rules (unquote $continue $branch $prompt $throw)
+  (syntax-rules (unquote $continue $branch $switch $prompt $throw)
     ((_ (unquote exp))
      exp)
     ((_ ($continue k src exp))
@@ -232,6 +233,8 @@
      (make-$branch kf kt src op param (list arg ...)))
     ((_ ($branch kf kt src op param args))
      (make-$branch kf kt src op param args))
+    ((_ ($switch kf kt* src arg))
+     (make-$switch kf kt* src arg))
     ((_ ($prompt k kh src escape? tag))
      (make-$prompt k kh src escape? tag))
     ((_ ($throw src op param (unquote args)))
@@ -299,6 +302,8 @@
      (build-term ($continue k (src exp) ,(parse-cps exp))))
     (('branch kf kt op param arg ...)
      (build-term ($branch kf kt (src exp) op param arg)))
+    (('switch kf (kt* ...) arg)
+     (build-term ($switch kf kt* (src exp) arg)))
     (('prompt k kh escape? tag)
      (build-term ($prompt k kh (src exp) escape? tag)))
     (('throw op param arg ...)
@@ -350,6 +355,8 @@
      `(continue ,k ,(unparse-cps exp)))
     (($ $branch kf kt src op param args)
      `(branch ,kf ,kt ,op ,param ,@args))
+    (($ $switch kf kt* src arg)
+     `(switch ,kf ,kt* ,arg))
     (($ $prompt k kh src escape? tag)
      `(prompt ,k ,kh ,escape? ,tag))
     (($ $throw src op param args)

module/language/cps/closure-conversion.scm

@@ -97,6 +97,8 @@ conts."
             (add-uses args uses))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
          (add-uses args uses))
+        (($ $kargs _ _ ($ $switch kf kt* src arg))
+         (add-use arg uses))
         (($ $kargs _ _ ($ $prompt k kh src escape? tag))
          (add-use tag uses))
         (($ $kargs _ _ ($ $throw src op param args))
@@ -118,6 +120,7 @@ conts."
           (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))
@@ -125,6 +128,7 @@ conts."
       (($ $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))
@@ -259,6 +263,8 @@ shared closures to use the appropriate 'self' variable, if possible."
          ($continue k src ,(visit-exp exp)))
         (($ $branch kf kt src op param args)
          ($branch kf kt src op param ,(map subst args)))
+        (($ $switch kf kt* src arg)
+         ($switch kf kt* src (subst arg)))
         (($ $prompt k kh src escape? tag)
          ($prompt k kh src escape? (subst tag)))
         (($ $throw src op param args)
@@ -386,6 +392,8 @@ references."
                          (add-uses args uses))))
                      (($ $branch kf kt src op param args)
                       (add-uses args uses))
+                     (($ $switch kf kt* src arg)
+                      (add-use arg uses))
                      (($ $prompt k kh src escape? tag)
                       (add-use tag uses))
                      (($ $throw src op param args)
@@ -826,6 +834,13 @@ bound to @var{var}, and continue to @var{k}."
                (build-term
                  ($branch kf kt src op param args))))))
 
+        (($ $switch kf kt* src arg)
+         (convert-arg cps arg
+           (lambda (cps arg)
+             (with-cps cps
+               (build-term
+                 ($switch kf kt* src arg))))))
+
         (($ $prompt k kh src escape? tag)
          (convert-arg cps tag
            (lambda (cps tag)

module/language/cps/compile-bytecode.scm

@@ -621,6 +621,12 @@
          (compile-test label (skip-elided-conts (1+ label))
                        (forward-label kf) (forward-label kt)
                        op param args))
+        (($ $switch kf kt* src arg)
+         (when src
+           (emit-source asm src))
+         (emit-jtable asm (from-sp (slot arg))
+                      (list->vector (map forward-label
+                                         (append kt* (list kf))))))
         (($ $prompt k kh src escape? tag)
          (when src
            (emit-source asm src))

module/language/cps/contification.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -62,6 +62,8 @@ predecessor."
       (($ $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))
@@ -193,6 +195,8 @@ $call, and are always called with a compatible arity."
             (exclude-vars functions args))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
          (exclude-vars functions args))
+        (($ $kargs _ _ ($ $switch kf kt* src arg))
+         (exclude-var functions arg))
         (($ $kargs _ _ ($ $prompt k kh src escape? tag))
          (exclude-var functions tag))
         (($ $kargs _ _ ($ $throw src op param args))
@@ -465,7 +469,7 @@ function set."
     (match term
       (($ $continue k src exp)
        (visit-exp cps k src exp))
-      ((or ($ $branch) ($ $prompt) ($ $throw))
+      ((or ($ $branch) ($ $switch) ($ $prompt) ($ $throw))
        (with-cps cps term))))
 
   ;; Renumbering is not strictly necessary but some passes may not be

module/language/cps/cse.scm

@@ -114,12 +114,19 @@ false.  It could be that both true and false proofs are available."
                        (propagate boolv succ1
                                   (intset-add in (true-idx label)))))
           (values (append changed0 changed1) boolv)))
+      (define (propagate* succs)
+        (fold2 (lambda (succ changed boolv)
+                 (call-with-values (lambda () (propagate boolv succ in))
+                   (lambda (changed* boolv)
+                     (values (append changed* changed) boolv))))
+               succs '() boolv))
 
       (match (intmap-ref conts label)
         (($ $kargs names vars term)
          (match term
            (($ $continue k)   (propagate1 k))
            (($ $branch kf kt) (propagate-branch kf kt))
+           (($ $switch kf kt*) (propagate* (cons kf kt*)))
            (($ $prompt k kh)  (propagate2 k kh))
            (($ $throw)        (propagate0))))
         (($ $kreceive arity k)
@@ -179,6 +186,8 @@ false.  It could be that both true and false proofs are available."
      ($kargs names vals ($continue (rename k) src ,exp)))
     (($ $kargs names vals ($ $branch kf kt src op param args))
      ($kargs names vals ($branch (rename kf) (rename kt) src op param args)))
+    (($ $kargs names vals ($ $switch kf kt* src arg))
+     ($kargs names vals ($switch (rename kf) (map rename kt*) src arg)))
     (($ $kargs names vals ($ $prompt k kh src escape? tag))
      ($kargs names vals ($prompt (rename k) (rename kh) src escape? tag)))
     (($ $kreceive ($ $arity req () rest () #f) kbody)
@@ -272,9 +281,12 @@ false.  It could be that both true and false proofs are available."
                         (intmap-replace truthy-labels label bool-in)))))))
 
 (define (term-successors term)
+  (define (list->intset ls)
+    (fold1 (lambda (elt set) (intset-add set elt)) ls empty-intset))
   (match term
     (($ $continue k) (intset k))
     (($ $branch kf kt) (intset kf kt))
+    (($ $switch kf kt*) (list->intset (cons kf kt*)))
     (($ $prompt k kh) (intset k kh))
     (($ $throw) empty-intset)))
 
@@ -346,6 +358,7 @@ false.  It could be that both true and false proofs are available."
     (match term
       (($ $continue k src exp)              (compute-expr-key exp))
       (($ $branch)                          (compute-branch-key term))
+      (($ $switch)                          #f)
       (($ $prompt)                          #f)
       (($ $throw)                           #f)))
 
@@ -424,6 +437,8 @@ false.  It could be that both true and false proofs are available."
     (rewrite-term term
       (($ $branch kf kt src op param args)
        ($branch kf kt src op param ,(map subst-var args)))
+      (($ $switch kf kt* src arg)
+       ($switch kf kt* src (subst-var arg)))
       (($ $continue k src exp)
        ($continue k src ,(rename-exp exp)))
       (($ $prompt k kh src escape? tag)
@@ -530,7 +545,7 @@ false.  It could be that both true and false proofs are available."
                                     ,(visit-exp label exp analysis)))))
                  substs
                  analysis))
-        ((or ($ $prompt) ($ $throw))
+        ((or ($ $switch) ($ $prompt) ($ $throw))
          (values (intmap-add! out label (build-cont ($kargs names vars ,term)))
                  substs
                  analysis)))))

module/language/cps/dce.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -80,10 +80,11 @@ sites."
                                      (causes-effect? fx &allocation))
                                 (values (intset-add! known k) unknown)
                                 (values known (intset-add! unknown k)))))
-                         (($ $kargs _ _ (or ($ $branch) ($ $prompt) ($ $throw)))
+                         (($ $kargs _ _ (or ($ $branch) ($ $switch)
-                          ;; Branches and prompts pass no values to
+                                            ($ $prompt) ($ $throw)))
-                          ;; their continuations, and throw terms don't
+                          ;; Branches, switches, and prompts pass no
-                          ;; continue at all.
+                          ;; values to their continuations, and throw
+                          ;; terms don't continue at all.
                           (values known unknown))
                          (($ $kreceive arity kargs)
                           (values known (intset-add! unknown kargs)))
@@ -204,7 +205,8 @@ sites."
         ;; Still dead.
         (values live-labels live-vars))))
 
-    (define (visit-branch label kf kt args live-labels live-vars)
+    ;; Note, this is for $branch or $switch.
+    (define (visit-branch label kf kt* args live-labels live-vars)
       (define (next-live-term k)
         ;; FIXME: For a chain of dead branches, this is quadratic.
         (let lp ((seen empty-intset) (k k))
@@ -216,12 +218,23 @@ sites."
               (($ $kargs _ _ ($ $continue k*))
                (lp (intset-add seen k) k*))
               (_ k))))))
+      (define (distinct-continuations?)
+        (let ((kf' (next-live-term kf)))
+          (let lp ((kt* kt*))
+            (match kt*
+              (() #f)
+              ((kt . kt*)
+               (cond
+                ((or (eqv? kf kt)
+                     (eqv? kf' (next-live-term kt)))
+                 (lp kt*))
+                (else #t)))))))
       (cond
        ((intset-ref live-labels label)
         ;; Branch live already.
         (values live-labels (adjoin-vars args live-vars)))
        ((or (causes-effect? (intmap-ref effects label) &type-check)
-            (not (eqv? (next-live-term kf) (next-live-term kt))))
+            (distinct-continuations?))
         ;; The branch is live if its continuations are not the same, or
         ;; if the branch itself causes type checks.
         (values (intset-add live-labels label)
@@ -238,7 +251,9 @@ sites."
            (($ $kargs _ _ ($ $continue k src exp))
             (visit-exp label k exp live-labels live-vars))
            (($ $kargs _ _ ($ $branch kf kt src op param args))
-            (visit-branch label kf kt args live-labels live-vars))
+            (visit-branch label kf (list kt) args live-labels live-vars))
+           (($ $kargs _ _ ($ $switch kf kt* src arg))
+            (visit-branch label kf kt* (list arg) live-labels live-vars))
            (($ $kargs _ _ ($ $prompt k kh src escape? tag))
             ;; Prompts need special elision passes that would contify
             ;; aborts and remove corresponding "unwind" primcalls.
@@ -357,6 +372,11 @@ sites."
            ;; Dead branches continue to the same continuation
            ;; (eventually).
            (values cps (build-term ($continue kf src ($values ()))))))
+      (($ $switch kf kt* src arg)
+       ;; Same as in $branch case.
+       (if (label-live? label)
+           (values cps term)
+           (values cps (build-term ($continue kf src ($values ()))))))
       (($ $prompt)
        (values cps term))
       (($ $throw)

module/language/cps/devirtualize-integers.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2017-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2017-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
@@ -75,6 +75,8 @@
                (add-uses use-counts args))))
            (($ $branch kf kt src op param args)
             (add-uses use-counts args))
+           (($ $switch kf kt* src arg)
+            (add-use use-counts arg))
            (($ $prompt k kh src escape? tag)
             (add-use use-counts tag))
            (($ $throw src op param args)
@@ -191,6 +193,10 @@ the trace should be referenced outside of it."
                   label*))
                (else
                 (fail)))))
+           (($ $switch)
+            ;; Don't know how to peel past a switch.  The arg of a
+            ;; switch is unboxed anyway.
+            (fail))
            (($ $continue k src exp)
             (match exp
               (($ $const)

module/language/cps/effects-analysis.scm

@@ -629,6 +629,7 @@ the LABELS that are clobbered by the effects of LABEL."
         (expression-effects exp))
        (($ $kargs names syms ($ $branch kf kt src op param args))
         (primitive-effects param op args))
+       (($ $kargs names syms ($ $switch)) &no-effects)
        (($ $kargs names syms ($ $prompt))
         ;; Although the "main" path just writes &prompt, we don't know
         ;; what nonlocal predecessors of the handler do, so we

module/language/cps/licm.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 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
@@ -204,7 +204,7 @@
                                      ($values fresh-vars))))))
                     (values cps cont loop-vars loop-effects
                             pre-header-label always-reached?)))))))))
-         ((or ($ $branch) ($ $throw))
+         ((or ($ $branch) ($ $switch) ($ $throw))
           (let* ((cont (build-cont ($kargs names vars ,term)))
                  (always-reached? #f))
             (values cps cont loop-vars loop-effects
@@ -260,6 +260,9 @@
         (($ $kargs names vars ($ $branch kf kt src op param args))
          ($kargs names vars
            ($branch (rename kf) (rename kt) src op param args)))
+        (($ $kargs names vars ($ $switch kf kt* src arg))
+         ($kargs names vars
+           ($switch (rename kf) (map rename kt*) src arg)))
         (($ $kargs names vars ($ $prompt k kh src escape? tag))
          ($kargs names vars
            ($prompt (rename k) (rename kh) src escape? tag)))

module/language/cps/loop-instrumentation.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2016, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2016, 2017, 2018, 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
@@ -44,6 +44,10 @@
        (maybe-add-header label k headers))
       (($ $kargs names vars ($ $branch kf kt))
        (maybe-add-header label kf (maybe-add-header label kt headers)))
+      (($ $kargs names vars ($ $switch kf kt*))
+       (fold1 (lambda (k headers) (maybe-add-header label k headers))
+              (cons kf kt*)
+              headers))
       (_ headers)))
   (persistent-intset (intmap-fold visit-cont cps empty-intset)))
 

module/language/cps/peel-loops.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -158,6 +158,9 @@
       (($ $branch kf kt src op param args)
        ($branch (rename-label kf) (rename-label kt) src
          op param ,(map rename-var args)))
+      (($ $switch kf kt* src arg)
+       ($switch (rename-label kf) (map rename-label kt*) src
+         (rename-var arg)))
       (($ $prompt k kh src escape? tag)
        ($prompt (rename-label k) (rename-label kh) src
          escape? (rename-var tag)))

module/language/cps/renumber.scm

@@ -93,6 +93,10 @@
                         (if (visit-kf-first? kf kt)
                             (visit2 kf kt order visited)
                             (visit2 kt kf order visited)))
+                       (($ $switch kf kt*)
+                        (fold2 visit
+                               (stable-sort (cons kf kt*) visit-kf-first?)
+                               order visited))
                        (($ $prompt k kh)
                         (visit2 k kh order visited))
                        (($ $throw)
@@ -211,6 +215,9 @@
                  (($ $branch kf kt src op param args)
                   ($branch (rename-label kf) (rename-label kt) src
                     op param ,(map rename-var args)))
+                 (($ $switch kf kt* src arg)
+                  ($switch (rename-label kf) (map rename-label kt*) src
+                    (rename-var arg)))
                  (($ $prompt k kh src escape? tag)
                   ($prompt (rename-label k) (rename-label kh) src
                     escape? (rename-var tag)))

module/language/cps/rotate-loops.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -121,6 +121,8 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
                   ($primcall name param ,(rename* args))))))
            (($ $branch kf kt src op param args)
             ($branch kf kt src op param ,(rename* args)))
+           (($ $switch kf kt* src arg)
+            ($switch kf kt* src (rename arg)))
            (($ $prompt k kh src escape? tag)
             ($prompt k kh src escape? (rename tag)))
            (($ $throw src op param args)
@@ -194,7 +196,7 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
     (intset-fold (lambda (label rotate?)
                    (match (intmap-ref cps label)
                      (($ $kreceive) #f)
-                     (($ $kargs _ _ ($ $branch)) #f)
+                     (($ $kargs _ _ (or ($ $branch) ($ $switch))) #f)
                      (($ $kargs _ _ ($ $continue)) rotate?)))
                  edges #t))
   (let* ((succs (compute-successors cps kfun))

module/language/cps/self-references.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -54,6 +54,8 @@
        ($continue k src ,(rename-exp exp)))
       (($ $branch kf kt src op param args)
        ($branch kf kt src op param ,(map subst args)))
+      (($ $switch kf kt* src arg)
+       ($switch kf kt* src (subst arg)))
       (($ $prompt k kh src escape? tag)
        ($prompt k kh src escape? (subst tag)))
       (($ $throw src op param args)

module/language/cps/simplify.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2015, 2017-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017-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
@@ -80,6 +80,8 @@
           (ref* args))))
       (($ $kargs _ _ ($ $branch kf kt src op param args))
        (ref* args))
+      (($ $kargs _ _ ($ $switch kf kt* src arg))
+       (ref arg))
       (($ $kargs _ _ ($ $prompt k kh src escape? tag))
        (ref tag))
       (($ $kargs _ _ ($ $throw src op param args))
@@ -149,6 +151,9 @@
               (($ $kargs names syms ($ $branch kf kt src op param args))
                ($kargs names syms
                  ($branch (subst kf) (subst kt) src op param args)))
+              (($ $kargs names syms ($ $switch kf kt* src arg))
+               ($kargs names syms
+                 ($switch (subst kf) (map subst kt*) src arg)))
               (($ $kargs names syms ($ $prompt k kh src escape? tag))
                ($kargs names syms
                  ($prompt (subst k) (subst kh) src escape? tag)))
@@ -195,6 +200,8 @@
       (($ $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))
@@ -266,6 +273,8 @@
                    ($values ,(map subst args))))))
             (($ $branch kf kt src op param args)
              ($branch kf kt src op param ,(map subst args)))
+            (($ $switch kf kt* src arg)
+             ($switch kf kt* src (subst arg)))
             (($ $prompt k kh src escape? tag)
              ($prompt k kh src escape? (subst tag)))
             (($ $throw src op param args)

module/language/cps/slot-allocation.scm

@@ -159,6 +159,8 @@ by a label, respectively."
             (return (get-defs k) (vars->intset args)))))
         (($ $kargs _ _ ($ $branch kf kt src op param args))
          (return empty-intset (vars->intset args)))
+        (($ $kargs _ _ ($ $switch kf kt* src arg))
+         (return empty-intset (intset arg)))
         (($ $kargs _ _ ($ $prompt k kh src escape? tag))
          (return empty-intset (intset tag)))
         (($ $kargs _ _ ($ $throw src op param args))
@@ -236,6 +238,10 @@ body continuation in the prompt."
               (visit-cont k level labels))
              (($ $kargs names syms ($ $branch kf kt))
               (visit-cont kf level (visit-cont kt level labels)))
+             (($ $kargs names syms ($ $switch kf kt*))
+              (fold1 (lambda (label labels)
+                       (visit-cont label level labels))
+                     (cons kf kt*) labels))
              (($ $kargs names syms ($ $prompt k kh src escape? tag))
               (visit-cont kh level (visit-cont k (1+ level) labels)))
              (($ $kargs names syms ($ $throw)) labels))))))))
@@ -788,7 +794,7 @@ are comparable with eqv?.  A tmp slot may be used."
                       (intmap-add representations var
                                   (intmap-ref representations arg)))
                     representations args vars))))))
-       (($ $kargs _ _ (or ($ $branch) ($ $prompt) ($ $throw)))
+       (($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
         representations)
        (($ $kfun src meta self)
         (if self

module/language/cps/specialize-numbers.scm

@@ -370,6 +370,8 @@ BITS indicating the significant bits needed for a variable.  BITS may be
                              (add-unknown-uses out args))))))
                    (($ $branch kf kt src op param args)
                     (add-unknown-uses out args))
+                   (($ $switch kf kt src arg)
+                    (add-unknown-use out arg))
                    (($ $prompt k kh src escape? tag)
                     (add-unknown-use out tag))
                    (($ $throw src op param args)

module/language/cps/split-rec.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013-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
@@ -93,6 +93,8 @@ references."
                          (add-uses args uses))))
                      (($ $branch kf kt src op param args)
                       (add-uses args uses))
+                     (($ $switch kf kt* src arg)
+                      (add-use arg uses))
                      (($ $prompt k kh src escape? tag)
                       (add-use tag uses))
                      (($ $throw src op param args)

module/language/cps/type-fold.scm

@@ -677,6 +677,11 @@
                              (with-cps cps
                                (setk label
                                      ($kargs names vars ,term)))))))))))))))
+    (define (branch-folded cps label names vars src k)
+      (with-cps cps
+        (setk label
+              ($kargs names vars
+                ($continue k src ($values ()))))))
     (define (fold-unary-branch cps label names vars kf kt src op param arg)
       (and=>
        (hashq-ref *branch-folders* op)
@@ -687,11 +692,8 @@
                (lambda (f? v)
                  ;; (when f? (pk 'folded-unary-branch label op arg v))
                  (and f?
-                      (with-cps cps
+                      (branch-folded cps label names vars src
-                        (setk label
+                                     (if v kt kf))))))))))
-                              ($kargs names vars
-                                ($continue (if v kt kf) src
-                                  ($values ())))))))))))))
     (define (fold-binary-branch cps label names vars kf kt src op param arg0 arg1)
       (and=>
        (hashq-ref *branch-folders* op)
@@ -705,11 +707,8 @@
                    (lambda (f? v)
                      ;; (when f? (pk 'folded-binary-branch label op arg0 arg1 v))
                      (and f?
-                          (with-cps cps
+                          (branch-folded cps label names vars src
-                            (setk label
+                                         (if v kt kf))))))))))))
-                                  ($kargs names vars
-                                    ($continue (if v kt kf) src
-                                      ($values ())))))))))))))))
     (define (fold-branch cps label names vars kf kt src op param args)
       (match args
         ((x)
@@ -729,6 +728,24 @@
       (or (fold-branch cps label names vars kf kt src op param args)
           (reduce-branch cps label names vars kf kt src op param args)
           cps))
+    (define (visit-switch cps label names vars kf kt* src arg)
+      ;; We might be able to fold or reduce a switch.
+      (let ((ntargets (length kt*)))
+        (call-with-values (lambda () (lookup-pre-type types label arg))
+          (lambda (type min max)
+            (cond
+             ((<= ntargets min)
+              (branch-folded cps label names vars src kf))
+             ((= min max)
+              (branch-folded cps label names vars src (list-ref kt* min)))
+             (else
+              ;; There are two more optimizations we could do here: one,
+              ;; if max is less than ntargets, we can prune targets at
+              ;; the end of the switch, and perhaps reduce the switch
+              ;; back to a branch; and two, if min is greater than 0,
+              ;; then we can subtract off min and prune targets at the
+              ;; beginning.  Not done yet though.
+              cps))))))
     (let lp ((label start) (cps cps))
       (if (<= label end)
           (lp (1+ label)
@@ -738,6 +755,8 @@
                  (visit-primcall cps label names vars k src op param args))
                 (($ $kargs names vars ($ $branch kf kt src op param args))
                  (visit-branch cps label names vars kf kt src op param args))
+                (($ $kargs names vars ($ $switch kf kt* src arg))
+                 (visit-switch cps label names vars kf kt* src arg))
                 (_ cps)))
           cps))))
 

module/language/cps/types.scm

@@ -1870,6 +1870,7 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)."
     (($ $kargs _ _ ($ $throw)) 0)
     (($ $kargs _ _ ($ $continue)) 1)
     (($ $kargs _ _ (or ($ $branch) ($ $prompt))) 2)
+    (($ $kargs _ _ ($ $switch kf kt*)) (1+ (length kt*)))
     (($ $kfun src meta self tail clause) (if clause 1 0))
     (($ $kclause arity body alt) (if alt 2 1))
     (($ $kreceive) 1)
@@ -2066,6 +2067,24 @@ maximum, where type is a bitset as a fixnum."
          ;; The "normal" continuation is the #f branch.
          (propagate2 kf (infer-primcall types 0 op param args #f)
                      kt (infer-primcall types 1 op param args #f)))
+        (($ $kargs names vars ($ $switch kf kt* src arg))
+         (define (restrict-index min max)
+           (restrict-var types arg (make-type-entry &u64 min max)))
+         (define (visit-default typev)
+           (let ((types (restrict-index (length kt*) &u64-max)))
+             (propagate-types label typev 0 kf types)))
+         (define (visit-target typev k i)
+           (let ((types (restrict-index i i)))
+             (propagate-types label typev (1+ i) k types)))
+         (call-with-values (lambda () (visit-default typev))
+           (lambda (changed typev)
+             (let lp ((kt* kt*) (i 0) (changed changed) (typev typev))
+               (match kt*
+                 (() (values changed typev))
+                 ((kt . kt*)
+                  (call-with-values (lambda () (visit-target typev kt i))
+                    (lambda (changed* typev)
+                      (lp kt* (1+ i) (append changed* changed) typev)))))))))
         (($ $kargs names vars ($ $prompt k kh src escape? tag))
          ;; The "normal" continuation enters the prompt.
          (propagate2 k types kh types))

module/language/cps/utils.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018, 2019, 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
@@ -122,6 +122,8 @@
                (visit-cont k labels))
               (($ $branch kf kt)
                (visit-cont kf (visit-cont kt labels)))
+              (($ $switch kf kt*)
+               (visit-cont kf (fold1 visit-cont kt* labels)))
               (($ $prompt k kh)
                (visit-cont k (visit-cont kh labels)))
               (($ $throw)
@@ -176,6 +178,10 @@ intset."
       (define (propagate2 succ0 succ1)
         (let ((succs (intmap-add! succs label (intset succ0 succ1))))
           (visit succ1 (visit succ0 succs))))
+      (define (propagate* k*)
+        (define (list->intset ls)
+          (fold1 (lambda (elt set) (intset-add set elt)) ls empty-intset))
+        (fold1 visit k* (intmap-add! succs label (list->intset k*))))
       (if (intmap-ref succs label (lambda (_) #f))
           succs
           (match (intmap-ref conts label)
@@ -183,6 +189,7 @@ intset."
              (match term
                (($ $continue k) (propagate1 k))
                (($ $branch kf kt) (propagate2 kf kt))
+               (($ $switch kf kt*) (propagate* (cons kf kt*)))
                (($ $prompt k kh) (propagate2 k kh))
                (($ $throw) (propagate0))))
             (($ $kreceive arity k)
@@ -218,6 +225,7 @@ intset."
        (match term
          (($ $continue k)   (add-pred k preds))
          (($ $branch kf kt) (add-pred kf (add-pred kt preds)))
+         (($ $switch kf kt*) (fold1 add-pred (cons kf kt*) preds))
          (($ $prompt k kh)  (add-pred k (add-pred kh preds)))
          (($ $throw)        preds)))))
   (persistent-intmap

module/language/cps/verify.scm

@@ -1,5 +1,5 @@
 ;;; Diagnostic checker for CPS
-;;; Copyright (C) 2014-2019 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-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
@@ -97,6 +97,13 @@ definitions that are available at LABEL."
         (let*-values (((changed0 defs) (propagate defs succ0 out))
                       ((changed1 defs) (propagate defs succ1 out)))
           (values (append changed0 changed1) defs)))
+      (define (propagate* succs out)
+        (let lp ((succs succs) (changed '()) (defs defs))
+          (match succs
+            (() (values changed defs))
+            ((succ . succs)
+             (let-values (((changed* defs) (propagate defs succ out)))
+               (lp succs (append changed* changed) defs))))))
 
       (match (intmap-ref conts label)
         (($ $kargs names vars term)
@@ -106,6 +113,8 @@ definitions that are available at LABEL."
               (propagate1 k out))
              (($ $branch kf kt)
               (propagate2 kf kt out))
+             (($ $switch kf kt*)
+              (propagate* (cons kf kt*) out))
              (($ $prompt k kh)
               (propagate2 k kh out))
              (($ $throw)
@@ -208,6 +217,9 @@ definitions that are available at LABEL."
         (($ $branch kf kt src name param args)
          (for-each check-use args)
          first-order)
+        (($ $switch kf kt* src arg)
+         (check-use arg)
+         first-order)
         (($ $prompt k kh src escape? tag)
          (check-use tag)
          first-order)
@@ -290,20 +302,21 @@ definitions that are available at LABEL."
             (($ $primcall 'call-thunk/no-inline #f (thunk)) #t)
             (_ (cont (error "bad continuation" exp cont)))))))))
   (define (check-term term)
+    (define (assert-nullary k)
+      (match (intmap-ref conts k)
+        (($ $kargs () ()) #t)
+        (cont (error "expected nullary cont" cont))))
     (match term
       (($ $continue k src exp)
        (check-arity exp (intmap-ref conts k)))
       (($ $branch kf kt src op param args)
-       (match (intmap-ref conts kf)
+       (assert-nullary kf)
-         (($ $kargs () ()) #t)
+       (assert-nullary kt))
-         (cont (error "bad kf" cont)))
+      (($ $switch kf kt* src arg)
-       (match (intmap-ref conts kt)
+       (assert-nullary kf)
-         (($ $kargs () ()) #t)
+       (for-each assert-nullary kt*))
-         (cont (error "bad kt" cont))))
       (($ $prompt k kh src escape? tag)
-       (match (intmap-ref conts k)
+       (assert-nullary k)
-         (($ $kargs () ()) #t)
-         (cont (error "bad prompt body" cont)))
        (match (intmap-ref conts kh)
          (($ $kreceive) #t)
          (cont (error "bad prompt handler" cont))))