wingo pushed a commit to branch master
in repository guile.
commit 6485e89276b262245251415c26492e2ab677085b
Author: Andy Wingo <wi...@pobox.com>
Date: Fri May 1 13:18:22 2015 +0200
Beginnings of CPS2 language.
The tentative plan is to replace CPS with CPS2, and to rename CPS2 to
CPS. We will add a pass to compile tree-il to CPS2, then work from
the top down to replace the CPS compiler passes.
* module/language/cps2.scm:
* module/language/cps2/compile-cps.scm:
* module/language/cps2/renumber.scm:
* module/language/cps2/utils.scm: New files.
* module/Makefile.am: Add new files to build.
---
.dir-locals.el | 6 +
module/Makefile.am | 7 +
module/language/cps2.scm | 362 ++++++++++++++++++++++++++++++++++
module/language/cps2/compile-cps.scm | 102 ++++++++++
module/language/cps2/renumber.scm | 218 ++++++++++++++++++++
module/language/cps2/utils.scm | 228 +++++++++++++++++++++
6 files changed, 923 insertions(+), 0 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 399b8d2..895c112 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -21,6 +21,12 @@
(eval . (put 'rewrite-cps-term 'scheme-indent-function 1))
(eval . (put 'rewrite-cps-cont 'scheme-indent-function 1))
(eval . (put 'rewrite-cps-exp 'scheme-indent-function 1))
+ (eval . (put 'build-term 'scheme-indent-function 0))
+ (eval . (put 'build-exp 'scheme-indent-function 0))
+ (eval . (put 'build-cont 'scheme-indent-function 0))
+ (eval . (put 'rewrite-term 'scheme-indent-function 1))
+ (eval . (put 'rewrite-cont 'scheme-indent-function 1))
+ (eval . (put 'rewrite-exp 'scheme-indent-function 1))
(eval . (put '$letk 'scheme-indent-function 1))
(eval . (put '$letk* 'scheme-indent-function 1))
(eval . (put '$letconst 'scheme-indent-function 1))
diff --git a/module/Makefile.am b/module/Makefile.am
index 5f4baae..2a7b9e8 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -59,6 +59,7 @@ SOURCES = \
\
language/tree-il.scm \
$(TREE_IL_LANG_SOURCES) \
+ $(CPS2_LANG_SOURCES) \
$(CPS_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
$(VALUE_LANG_SOURCES) \
@@ -147,6 +148,12 @@ CPS_LANG_SOURCES =
\
language/cps/type-fold.scm \
language/cps/verify.scm
+CPS2_LANG_SOURCES = \
+ language/cps2.scm \
+ language/cps2/compile-cps.scm \
+ language/cps2/renumber.scm \
+ language/cps2/utils.scm
+
BYTECODE_LANG_SOURCES = \
language/bytecode.scm \
language/bytecode/spec.scm
diff --git a/module/language/cps2.scm b/module/language/cps2.scm
new file mode 100644
index 0000000..6476c2d
--- /dev/null
+++ b/module/language/cps2.scm
@@ -0,0 +1,362 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; [Transitional note: CPS2 is a new version of CPS, and is a bit of an
+;;; experiment. All of the comments in this file pretend that CPS2 will
+;;; replace CPS, and will be named CPS.]
+;;;
+;;; This is the continuation-passing style (CPS) intermediate language
+;;; (IL) for Guile.
+;;;
+;;; In CPS, a term is a labelled expression that calls a continuation.
+;;; A function is a collection of terms. No term belongs to more than
+;;; one function. The function is identified by the label of its entry
+;;; term, and its body is composed of those terms that are reachable
+;;; from the entry term. A program is a collection of functions,
+;;; identified by the entry label of the entry function.
+;;;
+;;; Terms are themselves wrapped in continuations, which specify how
+;;; predecessors may continue to them. For example, a $kargs
+;;; continuation specifies that the term may be called with a specific
+;;; number of values, and that those values will then be bound to
+;;; lexical variables. $kreceive specifies that some number of values
+;;; will be passed on the stack, as from a multiple-value return. Those
+;;; values will be passed to a $kargs, if the number of values is
+;;; compatible with the $kreceive's arity. $kfun is an entry point to a
+;;; function, and receives arguments according to a well-known calling
+;;; convention (currently, on the stack) and the stack before
+;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and
+;;; only appears within a $kfun; it checks the incoming values for the
+;;; correct arity and dispatches to a $kargs, or to the next clause.
+;;; Finally, $ktail is the tail continuation for a function, and
+;;; contains no term.
+;;;
+;;; Each continuation has a label that is unique in the program. As an
+;;; implementation detail, the labels are integers, which allows us to
+;;; easily sort them topologically. A program is a map from integers to
+;;; continuations, where continuation 0 in the map is the entry point
+;;; for the program, and is a $kfun of no arguments.
+;;;
+;;; $continue nodes call continuations. The expression contained in the
+;;; $continue node determines the value or values that are passed to the
+;;; target continuation: $const to pass a constant value, $values to
+;;; pass multiple named values, etc. $continue nodes also record the
+;;; source location corresponding to the expression.
+;;;
+;;; As mentioned above, a $kargs continuation can bind variables, if it
+;;; receives incoming values. $kfun also binds a value, corresponding
+;;; to the closure being called. A traditional CPS implementation will
+;;; nest terms in each other, binding them in "let" forms, ensuring that
+;;; continuations are declared and bound within the scope of the values
+;;; that they may use. In this way, the scope tree is a proof that
+;;; variables are defined before they are used. However, this proof is
+;;; conservative; it is possible for a variable to always be defined
+;;; before it is used, but not to be in scope:
+;;;
+;;; (letrec ((k1 (lambda (v1) (k2)))
+;;; (k2 (lambda () v1)))
+;;; (k1 0))
+;;;
+;;; This example is invalid, as v1 is used outside its scope. However
+;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside
+;;; k1:
+;;;
+;;; (letrec ((k1 (lambda (v1)
+;;; (letrec ((k2 (lambda () v1)))
+;;; (k2))))
+;;; (k1 0))
+;;;
+;;; Because program transformation usually uses flow-based analysis,
+;;; having to update the scope tree to manifestly prove a transformation
+;;; that has already proven correct is needless overhead, and in the
+;;; worst case can prevent optimizations from occuring. For that
+;;; reason, Guile's CPS language does not nest terms. Instead, we use
+;;; the invariant that definitions must dominate uses. To check the
+;;; validity of a CPS program is thus more involved than checking for a
+;;; well-scoped tree; you have to do flow analysis to determine a
+;;; dominator tree. However the flexibility that this grants us is
+;;; worth the cost of throwing away the embedded proof of the scope
+;;; tree.
+;;;
+;;; This particular formulation of CPS was inspired by Andrew Kennedy's
+;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
+;;; hackers should read that excellent paper! As in Kennedy's paper,
+;;; continuations are second-class, and may be thought of as basic block
+;;; labels. All values are bound to variables using continuation calls:
+;;; even constants!
+;;;
+;;; Finally, note that there are two flavors of CPS: higher-order and
+;;; first-order. By "higher-order", we mean that variables may be free
+;;; across function boundaries. Higher-order CPS contains $fun and $rec
+;;; expressions that declare functions in the scope of their term.
+;;; Closure conversion results in first-order CPS, where closure
+;;; representations have been explicitly chosen, and all variables used
+;;; in a function are bound. Higher-order CPS is good for
+;;; interprocedural optimizations like contification and beta reduction,
+;;; while first-order CPS is better for instruction selection, register
+;;; allocation, and code generation.
+;;;
+;;; See (language tree-il compile-cps) for details on how Tree-IL
+;;; converts to CPS.
+;;;
+;;; Code:
+
+(define-module (language cps2)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:export (;; Helper.
+ $arity
+ make-$arity
+
+ ;; Continuations.
+ $kreceive $kargs $kfun $ktail $kclause
+
+ ;; Terms.
+ $continue
+
+ ;; Expressions.
+ $const $prim $fun $rec $closure $branch
+ $call $callk $primcall $values $prompt
+
+ ;; Building macros.
+ build-cont build-term build-exp
+ rewrite-cont rewrite-term rewrite-exp
+
+ ;; External representation.
+ parse-cps unparse-cps))
+
+;; FIXME: Use SRFI-99, when Guile adds it.
+(define-syntax define-record-type*
+ (lambda (x)
+ (define (id-append ctx . syms)
+ (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+ (syntax-case x ()
+ ((_ name field ...)
+ (and (identifier? #'name) (and-map identifier? #'(field ...)))
+ (with-syntax ((cons (id-append #'name #'make- #'name))
+ (pred (id-append #'name #'name #'?))
+ ((getter ...) (map (lambda (f)
+ (id-append f #'name #'- f))
+ #'(field ...))))
+ #'(define-record-type name
+ (cons field ...)
+ pred
+ (field getter)
+ ...))))))
+
+(define-syntax-rule (define-cps-type name field ...)
+ (begin
+ (define-record-type* name field ...)
+ (set-record-type-printer! name print-cps)))
+
+(define (print-cps exp port)
+ (format port "#<cps ~S>" (unparse-cps exp)))
+
+;; Helper.
+(define-record-type* $arity req opt rest kw allow-other-keys?)
+
+;; Continuations
+(define-cps-type $kreceive arity kbody)
+(define-cps-type $kargs names syms term)
+(define-cps-type $kfun src meta self ktail kclause)
+(define-cps-type $ktail)
+(define-cps-type $kclause arity kbody kalternate)
+
+;; Terms.
+(define-cps-type $continue k src exp)
+
+;; Expressions.
+(define-cps-type $const val)
+(define-cps-type $prim name)
+(define-cps-type $fun body) ; Higher-order.
+(define-cps-type $rec names syms funs) ; Higher-order.
+(define-cps-type $closure label nfree) ; First-order.
+(define-cps-type $branch kt exp)
+(define-cps-type $call proc args)
+(define-cps-type $callk k proc args) ; First-order.
+(define-cps-type $primcall name args)
+(define-cps-type $values args)
+(define-cps-type $prompt escape? tag handler)
+
+(define-syntax build-arity
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (req opt rest kw allow-other-keys?))
+ (make-$arity req opt rest kw allow-other-keys?))))
+
+(define-syntax build-cont
+ (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($kreceive req rest kargs))
+ (make-$kreceive (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kargs (name ...) (unquote syms) body))
+ (make-$kargs (list name ...) syms (build-term body)))
+ ((_ ($kargs (name ...) (sym ...) body))
+ (make-$kargs (list name ...) (list sym ...) (build-term body)))
+ ((_ ($kargs names syms body))
+ (make-$kargs names syms (build-term body)))
+ ((_ ($kfun src meta self ktail kclause))
+ (make-$kfun src meta self ktail kclause))
+ ((_ ($ktail))
+ (make-$ktail))
+ ((_ ($kclause arity kbody kalternate))
+ (make-$kclause (build-arity arity) kbody kalternate))))
+
+(define-syntax build-term
+ (syntax-rules (unquote $rec $continue)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($continue k src exp))
+ (make-$continue k src (build-exp exp)))))
+
+(define-syntax build-exp
+ (syntax-rules (unquote
+ $const $prim $fun $rec $closure $branch
+ $call $callk $primcall $values $prompt)
+ ((_ (unquote exp)) exp)
+ ((_ ($const val)) (make-$const val))
+ ((_ ($prim name)) (make-$prim name))
+ ((_ ($fun kentry)) (make-$fun kentry))
+ ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
+ ((_ ($closure k nfree)) (make-$closure k nfree))
+ ((_ ($call proc (unquote args))) (make-$call proc args))
+ ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+ ((_ ($call proc args)) (make-$call proc args))
+ ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
+ ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
+ ((_ ($callk k proc args)) (make-$callk k proc args))
+ ((_ ($primcall name (unquote args))) (make-$primcall name args))
+ ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+ ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (unquote args))) (make-$values args))
+ ((_ ($values (arg ...))) (make-$values (list arg ...)))
+ ((_ ($values args)) (make-$values args))
+ ((_ ($branch kt exp)) (make-$branch kt (build-exp exp)))
+ ((_ ($prompt escape? tag handler))
+ (make-$prompt escape? tag handler))))
+
+(define-syntax-rule (rewrite-cont x (pat cont) ...)
+ (match x
+ (pat (build-cont cont)) ...))
+(define-syntax-rule (rewrite-term x (pat term) ...)
+ (match x
+ (pat (build-term term)) ...))
+(define-syntax-rule (rewrite-exp x (pat body) ...)
+ (match x
+ (pat (build-exp body)) ...))
+
+(define (parse-cps exp)
+ (define (src exp)
+ (let ((props (source-properties exp)))
+ (and (pair? props) props)))
+ (match exp
+ ;; Continuations.
+ (('kreceive req rest k)
+ (build-cont ($kreceive req rest k)))
+ (('kargs names syms body)
+ (build-cont ($kargs names syms ,(parse-cps body))))
+ (('kfun src meta self ktail kclause)
+ (build-cont ($kfun (src exp) meta self ktail kclause)))
+ (('ktail)
+ (build-cont ($ktail)))
+ (('kclause (req opt rest kw allow-other-keys?) kbody)
+ (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f)))
+ (('kclause (req opt rest kw allow-other-keys?) kbody kalt)
+ (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt)))
+
+ ;; Calls.
+ (('continue k exp)
+ (build-term ($continue k (src exp) ,(parse-cps exp))))
+ (('unspecified)
+ (build-exp ($const *unspecified*)))
+ (('const exp)
+ (build-exp ($const exp)))
+ (('prim name)
+ (build-exp ($prim name)))
+ (('fun kbody)
+ (build-exp ($fun kbody)))
+ (('closure k nfree)
+ (build-exp ($closure k nfree)))
+ (('rec (name sym fun) ...)
+ (build-exp ($rec name sym (map parse-cps fun))))
+ (('call proc arg ...)
+ (build-exp ($call proc arg)))
+ (('callk k proc arg ...)
+ (build-exp ($callk k proc arg)))
+ (('primcall name arg ...)
+ (build-exp ($primcall name arg)))
+ (('branch k exp)
+ (build-exp ($branch k ,(parse-cps exp))))
+ (('values arg ...)
+ (build-exp ($values arg)))
+ (('prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? tag handler)))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (unparse-cps exp)
+ (match exp
+ ;; Continuations.
+ (($ $kreceive ($ $arity req () rest () #f) k)
+ `(kreceive ,req ,rest ,k))
+ (($ $kargs names syms body)
+ `(kargs ,names ,syms ,(unparse-cps body)))
+ (($ $kfun src meta self ktail kclause)
+ `(kfun ,meta ,self ,ktail ,kclause))
+ (($ $ktail)
+ `(ktail))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)
+ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody
+ . ,(if kalternate (list kalternate) '())))
+
+ ;; Calls.
+ (($ $continue k src exp)
+ `(continue ,k ,(unparse-cps exp)))
+ (($ $const val)
+ (if (unspecified? val)
+ '(unspecified)
+ `(const ,val)))
+ (($ $prim name)
+ `(prim ,name))
+ (($ $fun kbody)
+ `(fun ,kbody))
+ (($ $closure k nfree)
+ `(closure ,k ,nfree))
+ (($ $rec names syms funs)
+ `(rec ,@(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)))
+ (($ $call proc args)
+ `(call ,proc ,@args))
+ (($ $callk k proc args)
+ `(callk ,k ,proc ,@args))
+ (($ $primcall name args)
+ `(primcall ,name ,@args))
+ (($ $branch k exp)
+ `(branch ,k ,(unparse-cps exp)))
+ (($ $values args)
+ `(values ,@args))
+ (($ $prompt escape? tag handler)
+ `(prompt ,escape? ,tag ,handler))
+ (_
+ (error "unexpected cps" exp))))
diff --git a/module/language/cps2/compile-cps.scm
b/module/language/cps2/compile-cps.scm
new file mode 100644
index 0000000..f02f760
--- /dev/null
+++ b/module/language/cps2/compile-cps.scm
@@ -0,0 +1,102 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; Compiling CPS2 to CPS. When/if CPS2 replaces CPS, this module will be
removed.
+;;;
+;;; Code:
+
+(define-module (language cps2 compile-cps)
+ #:use-module (ice-9 match)
+ #:use-module (language cps2)
+ #:use-module ((language cps) #:prefix cps:)
+ #:use-module (language cps2 utils)
+ #:use-module (language cps2 renumber)
+ #:use-module (language cps intmap)
+ #:export (compile-cps))
+
+;; Precondition: For each function in CONTS, the continuation names are
+;; topologically sorted.
+(define (conts->fun conts)
+ (define (convert-fun kfun)
+ (let ((doms (compute-dom-edges (compute-idoms conts kfun))))
+ (define (visit-cont label)
+ (cps:rewrite-cps-cont (intmap-ref conts label)
+ (($ $kargs names syms body)
+ (label (cps:$kargs names syms ,(redominate label (visit-term
body)))))
+ (($ $ktail)
+ (label (cps:$ktail)))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (label (cps:$kreceive req rest kargs)))))
+ (define (visit-clause label)
+ (and label
+ (cps:rewrite-cps-cont (intmap-ref conts label)
+ (($ $kclause ($ $arity req opt rest kw aok?) kbody kalt)
+ (label (cps:$kclause (req opt rest kw aok?)
+ ,(visit-cont kbody)
+ ,(visit-clause kalt)))))))
+ (define (redominate label term)
+ (define (visit-dom-conts label)
+ (match (intmap-ref conts label)
+ (($ $ktail) '())
+ (($ $kargs) (list (visit-cont label)))
+ (else
+ (cons (visit-cont label)
+ (visit-dom-conts* (intmap-ref doms label))))))
+ (define (visit-dom-conts* labels)
+ (match labels
+ (() '())
+ ((label . labels)
+ (append (visit-dom-conts label)
+ (visit-dom-conts* labels)))))
+ (cps:rewrite-cps-term (visit-dom-conts* (intmap-ref doms label))
+ (() ,term)
+ (conts (cps:$letk ,conts ,term))))
+ (define (visit-term term)
+ (cps:rewrite-cps-term term
+ (($ $continue k src (and ($ $fun) fun))
+ (cps:$continue k src ,(visit-fun fun)))
+ (($ $continue k src ($ $rec names syms funs))
+ (cps:$continue k src (cps:$rec names syms (map visit-fun funs))))
+ (($ $continue k src exp)
+ (cps:$continue k src ,(visit-exp exp)))))
+ (define (visit-exp exp)
+ (cps:rewrite-cps-exp exp
+ (($ $const val) (cps:$const val))
+ (($ $prim name) (cps:$prim name))
+ (($ $closure k nfree) (cps:$closure k nfree))
+ (($ $call proc args) (cps:$call proc args))
+ (($ $callk k proc args) (cps:$callk k proc args))
+ (($ $primcall name args) (cps:$primcall name args))
+ (($ $branch k exp) (cps:$branch k ,(visit-exp exp)))
+ (($ $values args) (cps:$values args))
+ (($ $prompt escape? tag handler) (cps:$prompt escape? tag handler))))
+ (define (visit-fun fun)
+ (cps:rewrite-cps-exp fun
+ (($ $fun body)
+ (cps:$fun ,(convert-fun body)))))
+
+ (cps:rewrite-cps-cont (intmap-ref conts kfun)
+ (($ $kfun src meta self tail clause)
+ (kfun (cps:$kfun src meta self (tail (cps:$ktail))
+ ,(visit-clause clause)))))))
+ (convert-fun 0))
+
+(define (compile-cps exp env opts)
+ (values (conts->fun (renumber exp)) env env))
diff --git a/module/language/cps2/renumber.scm
b/module/language/cps2/renumber.scm
new file mode 100644
index 0000000..a44f404
--- /dev/null
+++ b/module/language/cps2/renumber.scm
@@ -0,0 +1,218 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; A pass to renumber variables and continuation labels so that they
+;;; are contiguous within each function and, in the case of labels,
+;;; topologically sorted.
+;;;
+;;; Code:
+
+(define-module (language cps2 renumber)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps2)
+ #:use-module (language cps2 utils)
+ #:use-module (language cps intset)
+ #:use-module (language cps intmap)
+ #:export (renumber))
+
+(define* (compute-tail-path-lengths conts kfun preds)
+ (define (add-lengths labels lengths length)
+ (intset-fold (lambda (label lengths)
+ (intmap-add! lengths label length))
+ labels
+ lengths))
+ (define (compute-next labels lengths)
+ (intset-fold (lambda (label labels)
+ (fold1 (lambda (pred labels)
+ (if (intmap-ref lengths pred)
+ labels
+ (intset-add! labels pred)))
+ (intmap-ref preds label)
+ labels))
+ labels
+ empty-intset))
+ (define (visit labels lengths length)
+ (let ((lengths (add-lengths labels lengths length)))
+ (values (compute-next labels lengths) lengths (1+ length))))
+ (match (intmap-ref conts kfun)
+ (($ $kfun src meta self tail clause)
+ (worklist-fold2 visit (intset-add empty-intset tail) empty-intmap 0))))
+
+;; Topologically sort the continuation tree starting at k0, using
+;; reverse post-order numbering.
+(define (sort-labels-locally conts k0 path-lengths)
+ (let ((order '())
+ (visited empty-intset))
+ (define (visit k)
+ (define (maybe-visit k)
+ (unless (intset-ref visited k)
+ (visit k)))
+ (define (visit-successors k)
+ (match (intmap-ref conts k)
+ (($ $kargs names syms ($ $continue k src exp))
+ (match exp
+ (($ $prompt escape? tag handler)
+ (maybe-visit handler)
+ (maybe-visit k))
+ (($ $branch kt)
+ ;; Visit the successor with the shortest path length
+ ;; to the tail first, so that if the branches are
+ ;; unsorted, the longer path length will appear
+ ;; first. This will move a loop exit out of a loop.
+ (let ((k-len (intmap-ref path-lengths k))
+ (kt-len (intmap-ref path-lengths kt)))
+ (cond
+ ((if kt-len
+ (or (not k-len)
+ (< k-len kt-len)
+ ;; If the path lengths are the
+ ;; same, preserve original order
+ ;; to avoid squirreliness.
+ (and (= k-len kt-len) (< kt k)))
+ (if k-len #f (< kt k)))
+ (maybe-visit k)
+ (maybe-visit kt))
+ (else
+ (maybe-visit kt)
+ (maybe-visit k)))))
+ (_
+ (maybe-visit k))))
+ (($ $kreceive arity k) (maybe-visit k))
+ (($ $kclause arity kbody kalt)
+ (when kalt (visit kalt))
+ (maybe-visit kbody))
+ (($ $kfun src meta self tail clause)
+ (visit tail)
+ (when clause (visit clause)))
+ (_ #f)))
+
+ ;; Mark this continuation as visited.
+ (set! visited (intset-add! visited k))
+
+ ;; Visit unvisited successors.
+ (visit-successors k)
+
+ ;; Add k to the reverse post-order.
+ (set! order (cons k order)))
+
+ ;; Recursively visit all continuations reachable from k0.
+ (visit k0)
+
+ ;; Return the sorted order.
+ order))
+
+(define (compute-renaming conts kfun)
+ ;; labels := old -> new
+ ;; vars := old -> new
+ (define *next-label* -1)
+ (define *next-var* -1)
+ (define (rename-label label labels)
+ (set! *next-label* (1+ *next-label*))
+ (intmap-add! labels label *next-label*))
+ (define (rename-var sym vars)
+ (set! *next-var* (1+ *next-var*))
+ (intmap-add! vars sym *next-var*))
+ (define (rename label labels vars)
+ (values (rename-label label labels)
+ (match (intmap-ref conts label)
+ (($ $kargs names syms exp)
+ (fold1 rename-var syms vars))
+ (($ $kfun src meta self tail clause)
+ (rename-var self vars))
+ (_ vars))))
+ (define (visit-nested-funs k labels vars)
+ (match (intmap-ref conts k)
+ (($ $kargs names syms ($ $continue k src ($ $fun kfun)))
+ (visit-fun kfun labels vars))
+ (($ $kargs names syms ($ $continue k src ($ $rec names* syms*
+ (($ $fun kfun) ...))))
+ (fold2 visit-fun kfun labels vars))
+ (_ (values labels vars))))
+ (define (visit-fun kfun labels vars)
+ (let* ((preds (compute-predecessors conts kfun))
+ (path-lengths (compute-tail-path-lengths conts kfun preds))
+ (order (sort-labels-locally conts kfun path-lengths)))
+ ;; First rename locally, then recurse on nested functions.
+ (let-values (((labels vars) (fold2 rename order labels vars)))
+ (fold2 visit-nested-funs order labels vars))))
+ (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap)))
+ (values (persistent-intmap labels) (persistent-intmap vars))))
+
+(define* (renumber conts #:optional (kfun 0))
+ (let-values (((label-map var-map) (compute-renaming conts kfun)))
+ (define (rename-label label)
+ (or (intmap-ref label-map label) (error "what" label)))
+ (define (rename-var var)
+ (or (intmap-ref var-map var) (error "what2" var)))
+ (define (rename-exp exp)
+ (rewrite-exp exp
+ ((or ($ $const) ($ $prim)) ,exp)
+ (($ $closure k nfree)
+ ($closure (rename-label k) nfree))
+ (($ $fun body)
+ ($fun (rename-label body)))
+ (($ $rec names vars funs)
+ ($rec names (map rename-var vars) (map rename-exp funs)))
+ (($ $values args)
+ ($values ,(map rename-var args)))
+ (($ $call proc args)
+ ($call (rename-var proc) ,(map rename-var args)))
+ (($ $callk k proc args)
+ ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
+ (($ $branch kt exp)
+ ($branch (rename-label kt) ,(rename-exp exp)))
+ (($ $primcall name args)
+ ($primcall name ,(map rename-var args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (rename-var tag) (rename-label handler)))))
+ (define (rename-arity arity)
+ (match arity
+ (($ $arity req opt rest () aok?)
+ arity)
+ (($ $arity req opt rest kw aok?)
+ (match kw
+ (() arity)
+ (((kw kw-name kw-var) ...)
+ (let ((kw (map list kw kw-name (map rename-var kw-var))))
+ (make-$arity req opt rest kw aok?)))))))
+ (persistent-intmap
+ (intmap-fold
+ (lambda (old-k new-k out)
+ (intmap-add!
+ out
+ new-k
+ (rewrite-cont (intmap-ref conts old-k)
+ (($ $kargs names syms ($ $continue k src exp))
+ ($kargs names (map rename-var syms)
+ ($continue (rename-label k) src ,(rename-exp exp))))
+ (($ $kreceive ($ $arity req () rest () #f) k)
+ ($kreceive req rest (rename-label k)))
+ (($ $ktail)
+ ($ktail))
+ (($ $kfun src meta self tail clause)
+ ($kfun src meta (rename-var self) (rename-label tail)
+ (and clause (rename-label clause))))
+ (($ $kclause arity body alternate)
+ ($kclause ,(rename-arity arity) (rename-label body)
+ (and alternate (rename-label alternate)))))))
+ label-map
+ empty-intmap))))
diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm
new file mode 100644
index 0000000..8ef5f20
--- /dev/null
+++ b/module/language/cps2/utils.scm
@@ -0,0 +1,228 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; Helper facilities for working with CPS.
+;;;
+;;; Code:
+
+(define-module (language cps2 utils)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (language cps2)
+ #:use-module (language cps intset)
+ #:use-module (language cps intmap)
+ #:export (;; Fresh names.
+ label-counter var-counter
+ fresh-label fresh-var
+ with-fresh-name-state compute-max-label-and-var
+ let-fresh
+
+ ;; Various utilities.
+ fold1 fold2
+ intset->intmap
+ worklist-fold worklist-fold2
+ fixpoint
+
+ ;; Flow analysis.
+ compute-predecessors
+ compute-function-body
+ compute-idoms
+ compute-dom-edges
+ ))
+
+(define label-counter (make-parameter #f))
+(define var-counter (make-parameter #f))
+
+(define (fresh-label)
+ (let ((count (or (label-counter)
+ (error "fresh-label outside with-fresh-name-state"))))
+ (label-counter (1+ count))
+ count))
+
+(define (fresh-var)
+ (let ((count (or (var-counter)
+ (error "fresh-var outside with-fresh-name-state"))))
+ (var-counter (1+ count))
+ count))
+
+(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
+ (let* ((label (fresh-label)) ...
+ (var (fresh-var)) ...)
+ body ...))
+
+(define-syntax-rule (with-fresh-name-state fun body ...)
+ (call-with-values (lambda () (compute-max-label-and-var fun))
+ (lambda (max-label max-var)
+ (parameterize ((label-counter (1+ max-label))
+ (var-counter (1+ max-var)))
+ body ...))))
+
+(define (compute-max-label-and-var conts)
+ (values (or (intmap-prev conts) -1)
+ (intmap-fold (lambda (k cont max-var)
+ (match cont
+ (($ $kargs names syms body)
+ (apply max max-var syms))
+ (($ $kfun src meta self)
+ (max max-var self))
+ (_ max-var)))
+ conts
+ -1)))
+
+(define-inlinable (fold1 f l s0)
+ (let lp ((l l) (s0 s0))
+ (match l
+ (() s0)
+ ((elt . l) (lp l (f elt s0))))))
+
+(define-inlinable (fold2 f l s0 s1)
+ (let lp ((l l) (s0 s0) (s1 s1))
+ (match l
+ (() (values s0 s1))
+ ((elt . l)
+ (call-with-values (lambda () (f elt s0 s1))
+ (lambda (s0 s1)
+ (lp l s0 s1)))))))
+
+(define (intset->intmap f set)
+ (persistent-intmap
+ (intset-fold (lambda (label preds)
+ (intmap-add! preds label (f label)))
+ set empty-intmap)))
+
+(define (worklist-fold f in out)
+ (if (eq? in empty-intset)
+ out
+ (call-with-values (lambda () (f in out))
+ (lambda (in out)
+ (worklist-fold f in out)))))
+
+(define (worklist-fold2 f in out0 out1)
+ (if (eq? in empty-intset)
+ (values out0 out1)
+ (call-with-values (lambda () (f in out0 out1))
+ (lambda (in out0 out1)
+ (worklist-fold2 f in out0 out1)))))
+
+(define (fixpoint f x)
+ (let ((x* (f x)))
+ (if (eq? x x*) x* (f x*))))
+
+(define (compute-function-body conts kfun)
+ (persistent-intset
+ (let visit-cont ((label kfun) (labels empty-intset))
+ (cond
+ ((intset-ref labels label) labels)
+ (else
+ (let ((labels (intset-add! labels label)))
+ (match (intmap-ref conts label)
+ (($ $kreceive arity k) (visit-cont k labels))
+ (($ $kfun src meta self ktail kclause)
+ (let ((labels (visit-cont ktail labels)))
+ (if kclause
+ (visit-cont kclause labels)
+ labels)))
+ (($ $ktail) labels)
+ (($ $kclause arity kbody kalt)
+ (if kalt
+ (visit-cont kalt (visit-cont kbody labels))
+ (visit-cont kbody labels)))
+ (($ $kargs names syms ($ $continue k src exp))
+ (visit-cont k (match exp
+ (($ $branch k)
+ (visit-cont k labels))
+ (($ $callk k)
+ (visit-cont k labels))
+ (($ $prompt escape? tag k)
+ (visit-cont k labels))
+ (_ labels)))))))))))
+
+(define* (compute-predecessors conts kfun #:key
+ (labels (compute-function-body conts kfun)))
+ (define (meet cdr car)
+ (cons car cdr))
+ (define (add-preds label preds)
+ (define (add-pred k preds)
+ (intmap-add! preds k label meet))
+ (match (intmap-ref conts label)
+ (($ $kreceive arity k)
+ (add-pred k preds))
+ (($ $kfun src meta self ktail kclause)
+ (add-pred ktail (if kclause (add-pred kclause preds) preds)))
+ (($ $ktail)
+ preds)
+ (($ $kclause arity kbody kalt)
+ (add-pred kbody (if kalt (add-pred kalt preds) preds)))
+ (($ $kargs names syms ($ $continue k src exp))
+ (add-pred k
+ (match exp
+ (($ $branch k) (add-pred k preds))
+ (($ $prompt _ _ k) (add-pred k preds))
+ (_ preds))))))
+ (persistent-intmap
+ (intset-fold add-preds labels
+ (intset->intmap (lambda (label) '()) labels))))
+
+;; Precondition: For each function in CONTS, the continuation names are
+;; topologically sorted.
+(define (compute-idoms conts kfun)
+ ;; This is the iterative O(n^2) fixpoint algorithm, originally from
+ ;; Allen and Cocke ("Graph-theoretic constructs for program flow
+ ;; analysis", 1972). See the discussion in Cooper, Harvey, and
+ ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
+ (let ((preds-map (compute-predecessors conts kfun)))
+ (define (compute-idom idoms preds)
+ (match preds
+ (() -1)
+ ((pred) pred) ; Shortcut.
+ ((pred . preds)
+ (define (common-idom d0 d1)
+ ;; We exploit the fact that a reverse post-order is a
+ ;; topological sort, and so the idom of a node is always
+ ;; numerically less than the node itself.
+ (let lp ((d0 d0) (d1 d1))
+ (cond
+ ;; d0 or d1 can be false on the first iteration.
+ ((not d0) d1)
+ ((not d1) d0)
+ ((= d0 d1) d0)
+ ((< d0 d1) (lp d0 (intmap-ref idoms d1)))
+ (else (lp (intmap-ref idoms d0) d1)))))
+ (fold1 common-idom preds pred))))
+ (define (adjoin-idom label preds idoms)
+ (let ((idom (compute-idom idoms preds)))
+ ;; Don't use intmap-add! here.
+ (intmap-add idoms label idom (lambda (old new) new))))
+ (fixpoint (lambda (idoms)
+ (intmap-fold adjoin-idom preds-map idoms))
+ empty-intmap)))
+
+;; Compute a vector containing, for each node, a list of the nodes that
+;; it immediately dominates. These are the "D" edges in the DJ tree.
+(define (compute-dom-edges idoms)
+ (define (snoc cdr car) (cons car cdr))
+ (intmap-fold (lambda (label idom doms)
+ (let ((doms (intmap-add! doms label '())))
+ (cond
+ ((< idom 0) doms) ;; No edge to entry.
+ (else (intmap-add! doms idom label snoc)))))
+ idoms
+ empty-intmap))
