[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/04: Add $switch CPS term kind
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 03/04: Add $switch CPS term kind |
|
Date: |
Wed, 12 Aug 2020 17:32:28 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit cd5ab6377bb14cb8248e0ba577ee0c44bce43b60
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed Aug 5 22:57:04 2020 +0200
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 | 1 +
doc/ref/compiler.texi | 18 +++++++++++--
module/language/cps.scm | 13 ++++++---
module/language/cps/closure-conversion.scm | 15 +++++++++++
module/language/cps/compile-bytecode.scm | 6 +++++
module/language/cps/contification.scm | 8 ++++--
module/language/cps/cse.scm | 17 +++++++++++-
module/language/cps/dce.scm | 36 +++++++++++++++++++------
module/language/cps/devirtualize-integers.scm | 8 +++++-
module/language/cps/effects-analysis.scm | 1 +
module/language/cps/licm.scm | 7 +++--
module/language/cps/loop-instrumentation.scm | 6 ++++-
module/language/cps/peel-loops.scm | 5 +++-
module/language/cps/renumber.scm | 7 +++++
module/language/cps/rotate-loops.scm | 6 +++--
module/language/cps/self-references.scm | 4 ++-
module/language/cps/simplify.scm | 11 +++++++-
module/language/cps/slot-allocation.scm | 8 +++++-
module/language/cps/specialize-numbers.scm | 2 ++
module/language/cps/split-rec.scm | 4 ++-
module/language/cps/type-fold.scm | 39 ++++++++++++++++++++-------
module/language/cps/types.scm | 19 +++++++++++++
module/language/cps/utils.scm | 10 ++++++-
module/language/cps/verify.scm | 33 ++++++++++++++++-------
24 files changed, 236 insertions(+), 48 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index ba48961..90257e7 100644
--- a/.dir-locals.el
+++ b/.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))
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 4c0348f..27964e8 100644
--- a/doc/ref/compiler.texi
+++ b/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
-@code{$prompt}.
+to a different number of labels: @code{$branch}, @code{$switch},
+@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)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 99efc7e..9682061 100644
--- a/module/language/cps.scm
+++ b/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)
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 17a81f6..a40d466 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/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)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index edf338d..e7d8abc 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/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))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 7587fa3..031b0cd 100644
--- a/module/language/cps/contification.scm
+++ b/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
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 3cc48cd..1966467 100644
--- a/module/language/cps/cse.scm
+++ b/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)))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 5be573d..aa52611 100644
--- a/module/language/cps/dce.scm
+++ b/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)))
- ;; Branches and prompts pass no values to
- ;; their continuations, and throw terms don't
- ;; continue at all.
+ (($ $kargs _ _ (or ($ $branch) ($ $switch)
+ ($ $prompt) ($ $throw)))
+ ;; Branches, switches, and prompts pass no
+ ;; 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)
diff --git a/module/language/cps/devirtualize-integers.scm
b/module/language/cps/devirtualize-integers.scm
index e7efd21..471ca81 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/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)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index f5021c8..d9e883c 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/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
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index 698c2d8..80d073a 100644
--- a/module/language/cps/licm.scm
+++ b/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)))
diff --git a/module/language/cps/loop-instrumentation.scm
b/module/language/cps/loop-instrumentation.scm
index 845a35a..2f5f1fe 100644
--- a/module/language/cps/loop-instrumentation.scm
+++ b/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)))
diff --git a/module/language/cps/peel-loops.scm
b/module/language/cps/peel-loops.scm
index b1bb396..c28654f 100644
--- a/module/language/cps/peel-loops.scm
+++ b/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)))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 19080c5..c170f5c 100644
--- a/module/language/cps/renumber.scm
+++ b/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)))
diff --git a/module/language/cps/rotate-loops.scm
b/module/language/cps/rotate-loops.scm
index d80a272..caa1da3 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/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))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index 8f67861..0ac16f9 100644
--- a/module/language/cps/self-references.scm
+++ b/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)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 5bb8f4b..4515915 100644
--- a/module/language/cps/simplify.scm
+++ b/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)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index f3800f3..6a90db0 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/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
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 7fa8741..5749624 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/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)
diff --git a/module/language/cps/split-rec.scm
b/module/language/cps/split-rec.scm
index ee5f2f2..07bf7d9 100644
--- a/module/language/cps/split-rec.scm
+++ b/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)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index b87730c..e09cc69 100644
--- a/module/language/cps/type-fold.scm
+++ b/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
- (setk label
- ($kargs names vars
- ($continue (if v kt kf) src
- ($values ())))))))))))))
+ (branch-folded cps label names vars src
+ (if v kt kf))))))))))
(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
- (setk label
- ($kargs names vars
- ($continue (if v kt kf) src
- ($values ())))))))))))))))
+ (branch-folded cps label names vars src
+ (if v kt kf))))))))))))
(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))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 1c85da1..6364b70 100644
--- a/module/language/cps/types.scm
+++ b/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))
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index fff88ab..e1f5e3a 100644
--- a/module/language/cps/utils.scm
+++ b/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
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index cacde9e..88dcbc0 100644
--- a/module/language/cps/verify.scm
+++ b/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)
- (($ $kargs () ()) #t)
- (cont (error "bad kf" cont)))
- (match (intmap-ref conts kt)
- (($ $kargs () ()) #t)
- (cont (error "bad kt" cont))))
+ (assert-nullary kf)
+ (assert-nullary kt))
+ (($ $switch kf kt* src arg)
+ (assert-nullary kf)
+ (for-each assert-nullary kt*))
(($ $prompt k kh src escape? tag)
- (match (intmap-ref conts k)
- (($ $kargs () ()) #t)
- (cont (error "bad prompt body" cont)))
+ (assert-nullary k)
(match (intmap-ref conts kh)
(($ $kreceive) #t)
(cont (error "bad prompt handler" cont))))