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

Add $switch CPS term kind

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-08-05 22:57:04 +02:00
parent a7f4a6f1c4
commit cd5ab6377b
24 changed files with 236 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -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))

18
doc/ref/compiler.texi
View file

@ -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)

13
module/language/cps.scm
View file

@ -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)

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

@ -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)

6
module/language/cps/compile-bytecode.scm
View file

@ -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))

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

@ -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

17
module/language/cps/cse.scm
View file

@ -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)))))

36
module/language/cps/dce.scm
View file

@ -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)

8
module/language/cps/devirtualize-integers.scm
View file

@ -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)

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

@ -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

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

@ -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)))

6
module/language/cps/loop-instrumentation.scm
View file

@ -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)))

5
module/language/cps/peel-loops.scm
View file

@ -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)))

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

@ -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)))

6
module/language/cps/rotate-loops.scm
View file

@ -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))

4
module/language/cps/self-references.scm
View file

@ -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)

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

@ -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)

8
module/language/cps/slot-allocation.scm
View file

@ -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

2
module/language/cps/specialize-numbers.scm
View file

@ -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)

4
module/language/cps/split-rec.scm
View file

@ -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)

39
module/language/cps/type-fold.scm
View file

@ -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))))

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

@ -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))

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

@ -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

33
module/language/cps/verify.scm
View file

@ -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))))