* CPS language and Tree-IL->CPS->RTL compiler
@ 2013-08-29 7:49 Andy Wingo
2013-08-29 7:49 ` [PATCH 1/9] Add CPS language Andy Wingo
` (10 more replies)
0 siblings, 11 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel
Hi all,
This patchset implements the CPS compiler I've been working on over the
last couple months. At the end of it, you can
guild compile -t rtl foo.scm
and, if there are no bugs or unimplemented bits, at that point you have
a loadable .go with RTL code. (Try readelf -a on the .go!)
From the console the way to do it is:
(use-modules (system vm objcode))
(load-thunk-from-memory (compile foo #:to 'rtl))
That gives you the thunk that, when called, will execute FOO.
So with that intro, some more on CPS and the RTL VM. As you know we
have a new register-based VM, where all values have names (slots). It's
appropriate that the language that compiles to this VM also give names
to all intermediate values. CPS has this property. In addition, CPS
gives names to all control points, effectively giving a label to each
expression.
This CPS language was inspired by Andrew Kennedy's great 2007 paper,
"Compiling with Continuations, Continued". In particular, continuations
are /local/ to a function, so they really are basic block labels, and
all values are bound to variables via continuation calls -- even
constants.
As a little example:
(+ 1 2)
Here + is a primcall, so we would get:
($letk ((kone ($kargs (oneb)
($letk ((ktwo ($kargs (two)
($continue ktail
($primcall + one two)))))
($continue ktwo ($const 2))))))
($continue kone ($const 1)))
Here all CPS language constructs are prefixed with "$". Everything else
is a variable, except the + in the primcall.
As you can see it is incredibly verbose. At the same time it's very
simple, as there are only two kinds of terms: terms that bind
continuations, and terms that call continuations.
$letk binds a set of mutually recursive continuations, each one an
instance of $cont. A $cont declares the name and source of a
continuation, and then contains as a subterm the particular
continuation instance: $kif for test continuations, $kargs for
continuations that bind values, etc.
$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.
Additionally there is $letrec, a term that binds mutually recursive
functions. The contification pass will turn $letrec into $letk if
it can do so. Otherwise, the closure conversion pass will desugar
$letrec into an equivalent sequence of make-closure primcalls and
subsequent initializations of the captured variables of the
closures. You can think of $letrec as pertaining to "high CPS",
whereas later passes will only see "low CPS", which does not have
$letrec.
There are a bunch of Guile-specific quirks in this language, mostly
related to function prologues for the different kinds of arities, and
for things like multiple-value truncation and prompts. Check out
(language cps) for all the deal.
So, after that patch is the Tree-IL->CPS compiler. It simplifies a
number of Tree-IL concepts, fixing argument order, turning toplevel
references to primcalls, transforming prompts, assignment conversion,
etc. For this reason it's a bit hairy, but it seems to work fine. This
compiler runs *after* optimization passes on Tree-IL, so you still have
peval that runs over tree-il.
After that follow a bunch of passes to build up an RTL compiler. The
idea is to compile by incremental source-to-source passes, and at the
end you just assign slots to all variables and emit code directly.
If you ever worked with the old (language tree-il compile-glil) module,
you know it's very hairy, mostly because it's mixing code emission with
semantic transformations. Nowhere is this more evident than the
so-called "labels allocation" strategy, in which we try to allocate
procedures as basic blocks, if they all return to the same place. It's
a funky pass. It turns out this concept is well-studied and has a name,
"contification", and is cleanly expressed as a source-to-source pass
over CPS. So compile-rtl.scm is dumb: it just loops over all
expressions, emitting code for each of them, and emitting jumps and
shuffling registers as needed (based on a prior analysis pass).
In the end you can ,disassemble the code, thanks to the earlier RTL
work.
I don't want people to benchmark this stuff yet -- it's buggy and not
optimized. Don't use this work for anything serious. But if you're in
to hacking on it, that's cool. There are a number of optimization
passes that are needed (see compile-rtl.scm for a list), but currently
it's looking like the RTL compiler does significantly better on loops,
but struggles to keep up with the old VM for calls. This is
unsurprising, as calls really do work like stacks, and a stack VM has
many advantages there. But we think that with better slot allocation we
can probably be faster for calls as well.
Thank you, thank you, thank you to Mark Weaver for helping out with this
work! Without him there would be many more bugs. I've folded all of
his patches into this patchset, so please consider him the joint author
of all of this. In any case the bugs have forced him to page much of
this code into his head so we are better equipped as a project because
of that ;-)
Thank you also to Noah Lavine, who did an earlier pass at CPS
conversion. I considered starting from his work but it became clear
that many aspects of CPS would be nicer with changes in Tree-IL -- so I
took advantage of my maintenance of the old compiler to make various
changes there and in other parts of the runtime to get a cleaner CPS
compiler. In the end we took advantage of his vanguard-hacking, though
as ideas rather than as code. Thank you Noah!
There are not as many tests and documentation as one would like.
Ultimately it all just came together in the last couple of weeks, so I
think the next step is to write more tests and try the compiler on new
pieces of code. There are a couple bugs that we know about at this
point, and surely many more that we don't know about. I ask for some
lenience on this front while we figure out what the compiler should look
like :)
OK. WDYT, Ludo? Comments? OK to merge? :)
Cheers,
Andy
^ permalink raw reply [flat|nested] 17+ messages in thread
* [PATCH 1/9] Add CPS language
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 20:48 ` Ludovic Courtès
2013-08-29 7:49 ` [PATCH 2/9] (compile foo #:to 'cps) Andy Wingo
` (9 subsequent siblings)
10 siblings, 1 reply; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am:
* module/language/cps.scm:
* module/language/cps/verify.scm: Add CPS language.
* .dir-locals.el: Add indentation rules for some CPS forms.
---
.dir-locals.el | 27 ++-
module/Makefile.am | 5 +
module/language/cps.scm | 469 +++++++++++++++++++++++++++++++++++++++++
module/language/cps/verify.scm | 165 +++++++++++++++
4 files changed, 660 insertions(+), 6 deletions(-)
create mode 100644 module/language/cps.scm
create mode 100644 module/language/cps/verify.scm
diff --git a/.dir-locals.el b/.dir-locals.el
index a24e860..94a2126 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -5,12 +5,27 @@
(c-mode . ((c-file-style . "gnu")))
(scheme-mode
. ((indent-tabs-mode . nil)
- (eval . (put 'pass-if 'scheme-indent-function 1))
- (eval . (put 'pass-if-exception 'scheme-indent-function 2))
- (eval . (put 'pass-if-equal 'scheme-indent-function 2))
- (eval . (put 'with-test-prefix 'scheme-indent-function 1))
- (eval . (put 'with-code-coverage 'scheme-indent-function 1))
- (eval . (put 'with-statprof 'scheme-indent-function 1))))
+ (eval . (put 'pass-if 'scheme-indent-function 1))
+ (eval . (put 'pass-if-exception 'scheme-indent-function 2))
+ (eval . (put 'pass-if-equal 'scheme-indent-function 2))
+ (eval . (put 'with-test-prefix 'scheme-indent-function 1))
+ (eval . (put 'with-code-coverage 'scheme-indent-function 1))
+ (eval . (put 'with-statprof 'scheme-indent-function 1))
+ (eval . (put 'let-gensyms 'scheme-indent-function 1))
+ (eval . (put 'build-cps-term 'scheme-indent-function 0))
+ (eval . (put 'build-cps-exp 'scheme-indent-function 0))
+ (eval . (put 'build-cps-cont 'scheme-indent-function 0))
+ (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 '$letk 'scheme-indent-function 1))
+ (eval . (put '$letk* 'scheme-indent-function 1))
+ (eval . (put '$letconst 'scheme-indent-function 1))
+ (eval . (put '$continue 'scheme-indent-function 1))
+ (eval . (put '$kargs 'scheme-indent-function 2))
+ (eval . (put '$kentry 'scheme-indent-function 2))
+ (eval . (put '$kclause 'scheme-indent-function 1))
+ (eval . (put '$fun 'scheme-indent-function 2))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
diff --git a/module/Makefile.am b/module/Makefile.am
index dc7d058..1f66ac4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -53,6 +53,7 @@ SOURCES = \
language/glil.scm \
language/assembly.scm \
$(TREE_IL_LANG_SOURCES) \
+ $(CPS_LANG_SOURCES) \
$(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
@@ -115,6 +116,10 @@ TREE_IL_LANG_SOURCES = \
language/tree-il/debug.scm \
language/tree-il/spec.scm
+CPS_LANG_SOURCES = \
+ language/cps.scm \
+ language/cps/verify.scm
+
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm
diff --git a/module/language/cps.scm b/module/language/cps.scm
new file mode 100644
index 0000000..ac5642a
--- /dev/null
+++ b/module/language/cps.scm
@@ -0,0 +1,469 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;; This is the continuation-passing style (CPS) intermediate language
+;;; (IL) for Guile.
+;;;
+;;; There are two kinds of terms in CPS: terms that bind continuations,
+;;; and terms that call continuations.
+;;;
+;;; $letk binds a set of mutually recursive continuations, each one an
+;;; instance of $cont. A $cont declares the name and source of a
+;;; continuation, and then contains as a subterm the particular
+;;; continuation instance: $kif for test continuations, $kargs for
+;;; continuations that bind values, etc.
+;;;
+;;; $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.
+;;;
+;;; Additionally there is $letrec, a term that binds mutually recursive
+;;; functions. The contification pass will turn $letrec into $letk if
+;;; it can do so. Otherwise, the closure conversion pass will desugar
+;;; $letrec into an equivalent sequence of make-closure primcalls and
+;;; subsequent initializations of the captured variables of the
+;;; closures. You can think of $letrec as pertaining to "high CPS",
+;;; whereas later passes will only see "low CPS", which does not have
+;;; $letrec.
+;;;
+;;; 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!
+;;;
+;;; There are some Guile-specific quirks as well:
+;;;
+;;; - $ktrunc represents a continuation that receives multiple values,
+;;; but which truncates them to some number of required values,
+;;; possibly with a rest list.
+;;;
+;;; - $kentry labels an entry point for a $fun (a function), and
+;;; contains a $ktail representing the formal argument which is the
+;;; function's continuation.
+;;;
+;;; - $kentry also contains $kclause continuations, corresponding to
+;;; the case-lambda clauses of the function. $kclause actually
+;;; contains the clause body. This is because the $kclause
+;;; logically matches or doesn't match a given set of actual
+;;; arguments against a formal arity, then proceeds to a "body"
+;;; continuation (which is a $kargs).
+;;;
+;;; That's to say that a $fun can be matched like this:
+;;;
+;;; (match f
+;;; (($ $fun meta free
+;;; ($ $cont kentry src
+;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
+;;; (($ $kclause arity
+;;; ($ $cont kbody _ ($ $kargs names syms body)))
+;;; ...))))
+;;; #t))
+;;;
+;;; A $continue to ktail is in tail position. $kentry, $kclause,
+;;; and $ktail will never be seen elsewhere in a CPS term.
+;;;
+;;; - $prompt continues to the body of the prompt, having pushed on a
+;;; prompt whose handler will continue at its "handler"
+;;; continuation. The continuation of the prompt is responsible for
+;;; popping the prompt.
+;;;
+;;; In summary:
+;;;
+;;; - $letk, $letrec, and $continue are terms.
+;;;
+;;; - $cont is a continuation, containing a continuation body ($kargs,
+;;; $kif, etc).
+;;;
+;;; - $continue terms contain an expression ($call, $const, $fun,
+;;; etc).
+;;;
+;;; See (language tree-il compile-cps) for details on how Tree-IL
+;;; converts to CPS.
+;;;
+;;; Code:
+
+(define-module (language cps)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (;; Helper.
+ $arity
+ make-$arity
+
+ ;; Terms.
+ $letk $continue $letrec
+
+ ;; Continuations.
+ $cont
+
+ ;; Continuation bodies.
+ $kif $ktrunc $kargs $kentry $ktail $kclause
+
+ ;; Expressions.
+ $var $void $const $prim $fun $call $primcall $values $prompt
+
+ ;; Building macros.
+ let-gensyms
+ build-cps-term build-cps-cont build-cps-exp
+ rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
+
+ ;; Misc.
+ parse-cps unparse-cps
+ fold-conts fold-local-conts))
+
+;; 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?)
+
+;; Terms.
+(define-cps-type $letk conts body)
+(define-cps-type $continue k exp)
+(define-cps-type $letrec names syms funs body)
+
+;; Continuations
+(define-cps-type $cont k src cont)
+(define-cps-type $kif kt kf)
+(define-cps-type $ktrunc arity k)
+(define-cps-type $kargs names syms body)
+(define-cps-type $kentry self tail clauses)
+(define-cps-type $ktail)
+(define-cps-type $kclause arity cont)
+
+;; Expressions.
+(define-cps-type $var sym)
+(define-cps-type $void)
+(define-cps-type $const val)
+(define-cps-type $prim name)
+(define-cps-type $fun meta free body)
+(define-cps-type $call proc args)
+(define-cps-type $primcall name args)
+(define-cps-type $values args)
+(define-cps-type $prompt escape? tag handler)
+
+(define-syntax let-gensyms
+ (syntax-rules ()
+ ((_ (sym ...) body body* ...)
+ (let ((sym (gensym (symbol->string 'sym))) ...)
+ body body* ...))))
+
+(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-body
+ (syntax-rules (unquote $kif $ktrunc $kargs $kentry $ktail $kclause)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($kif kt kf))
+ (make-$kif kt kf))
+ ((_ ($ktrunc req rest kargs))
+ (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kargs (name ...) (sym ...) body))
+ (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
+ ((_ ($kargs names syms body))
+ (make-$kargs names syms (build-cps-term body)))
+ ((_ ($kentry self tail (unquote clauses)))
+ (make-$kentry self (build-cps-cont tail) clauses))
+ ((_ ($kentry self tail (clause ...)))
+ (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause) ...)))
+ ((_ ($ktail))
+ (make-$ktail))
+ ((_ ($kclause arity cont))
+ (make-$kclause (build-arity arity) (build-cps-cont cont)))))
+
+(define-syntax build-cps-cont
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (k src cont)) (make-$cont k src (build-cont-body cont)))))
+
+(define-syntax build-cps-exp
+ (syntax-rules (unquote
+ $var $void $const $prim $fun $call $primcall $values $prompt)
+ ((_ (unquote exp)) exp)
+ ((_ ($var sym)) (make-$var sym))
+ ((_ ($void)) (make-$void))
+ ((_ ($const val)) (make-$const val))
+ ((_ ($prim name)) (make-$prim name))
+ ((_ ($fun meta free body)) (make-$fun meta free (build-cps-cont body)))
+ ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+ ((_ ($call proc args)) (make-$call proc args))
+ ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+ ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (arg ...))) (make-$values (list arg ...)))
+ ((_ ($values args)) (make-$values args))
+ ((_ ($prompt escape? tag handler)) (make-$prompt escape? tag handler))))
+
+(define-syntax build-cps-term
+ (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($letk (unquote conts) body))
+ (make-$letk conts (build-cps-term body)))
+ ((_ ($letk (cont ...) body))
+ (make-$letk (list (build-cps-cont cont) ...)
+ (build-cps-term body)))
+ ((_ ($letk* () body))
+ (build-cps-term body))
+ ((_ ($letk* (cont conts ...) body))
+ (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
+ ((_ ($letconst () body))
+ (build-cps-term body))
+ ((_ ($letconst ((name sym val) tail ...) body))
+ (let-gensyms (kconst)
+ (build-cps-term
+ ($letk ((kconst #f ($kargs (name) (sym) ($letconst (tail ...) body))))
+ ($continue kconst ($const val))))))
+ ((_ ($letrec names gensyms funs body))
+ (make-$letrec names gensyms funs (build-cps-term body)))
+ ((_ ($continue k exp))
+ (make-$continue k (build-cps-exp exp)))))
+
+(define-syntax-rule (rewrite-cps-term x (pat body) ...)
+ (match x
+ (pat (build-cps-term body)) ...))
+(define-syntax-rule (rewrite-cps-cont x (pat body) ...)
+ (match x
+ (pat (build-cps-cont body)) ...))
+(define-syntax-rule (rewrite-cps-exp x (pat body) ...)
+ (match x
+ (pat (build-cps-exp body)) ...))
+
+(define (parse-cps exp)
+ (define (src exp)
+ (let ((props (source-properties exp)))
+ (and (pair? props) props)))
+ (match exp
+ ;; Continuations.
+ (('letconst k (name sym c) body)
+ (build-cps-term
+ ($letk ((k (src exp) ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ($continue k ($const c)))))
+ (('let k (name sym val) body)
+ (build-cps-term
+ ($letk ((k (src exp) ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ,(parse-cps val))))
+ (('letk (cont ...) body)
+ (build-cps-term
+ ($letk ,(map parse-cps cont) ,(parse-cps body))))
+ (('k sym body)
+ (build-cps-cont
+ (sym (src exp) ,(parse-cps body))))
+ (('kif kt kf)
+ (build-cont-body ($kif kt kf)))
+ (('ktrunc req rest k)
+ (build-cont-body ($ktrunc req rest k)))
+ (('kargs names syms body)
+ (build-cont-body ($kargs names syms ,(parse-cps body))))
+ (('kentry self tail clauses)
+ (build-cont-body
+ ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
+ (('ktail)
+ (build-cont-body
+ ($ktail)))
+ (('kclause (req opt rest kw allow-other-keys?) body)
+ (build-cont-body
+ ($kclause (req opt rest kw allow-other-keys?)
+ ,(parse-cps body))))
+ (('kseq body)
+ (build-cont-body ($kargs () () ,(parse-cps body))))
+
+ ;; Calls.
+ (('continue k exp)
+ (build-cps-term ($continue k ,(parse-cps exp))))
+ (('var sym)
+ (build-cps-exp ($var sym)))
+ (('void)
+ (build-cps-exp ($void)))
+ (('const exp)
+ (build-cps-exp ($const exp)))
+ (('prim name)
+ (build-cps-exp ($prim name)))
+ (('fun meta free body)
+ (build-cps-exp ($fun meta free ,(parse-cps body))))
+ (('letrec ((name sym fun) ...) body)
+ (build-cps-term
+ ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+ (('call proc arg ...)
+ (build-cps-exp ($call proc arg)))
+ (('primcall name arg ...)
+ (build-cps-exp ($primcall name arg)))
+ (('values arg ...)
+ (build-cps-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.
+ (($ $letk (($ $cont k src ($ $kargs (name) (sym) body)))
+ ($ $continue k ($ $const c)))
+ `(letconst ,k (,name ,sym ,c)
+ ,(unparse-cps body)))
+ (($ $letk (($ $cont k src ($ $kargs (name) (sym) body))) val)
+ `(let ,k (,name ,sym ,(unparse-cps val))
+ ,(unparse-cps body)))
+ (($ $letk conts body)
+ `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
+ (($ $cont sym src body)
+ `(k ,sym ,(unparse-cps body)))
+ (($ $kif kt kf)
+ `(kif ,kt ,kf))
+ (($ $ktrunc ($ $arity req () rest '() #f) k)
+ `(ktrunc ,req ,rest ,k))
+ (($ $kargs () () body)
+ `(kseq ,(unparse-cps body)))
+ (($ $kargs names syms body)
+ `(kargs ,names ,syms ,(unparse-cps body)))
+ (($ $kentry self tail clauses)
+ `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
+ (($ $ktail)
+ `(ktail))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
+ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
+
+ ;; Calls.
+ (($ $continue k exp)
+ `(continue ,k ,(unparse-cps exp)))
+ (($ $var sym)
+ `(var ,sym))
+ (($ $void)
+ `(void))
+ (($ $const val)
+ `(const ,val))
+ (($ $prim name)
+ `(prim ,name))
+ (($ $fun meta free body)
+ `(fun ,meta ,free ,(unparse-cps body)))
+ (($ $letrec names syms funs body)
+ `(letrec ,(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)
+ ,(unparse-cps body)))
+ (($ $call proc args)
+ `(call ,proc ,@args))
+ (($ $primcall name args)
+ `(primcall ,name ,@args))
+ (($ $values args)
+ `(values ,@args))
+ (($ $prompt escape? tag handler)
+ `(prompt ,escape? ,tag ,handler))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (fold-conts proc seed fun)
+ (define (cont-folder cont seed)
+ (match cont
+ (($ $cont k src cont)
+ (let ((seed (proc k src cont seed)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed))
+
+ (($ $kentry self tail clauses)
+ (fold cont-folder (cont-folder tail seed) clauses))
+
+ (($ $kclause arity body)
+ (cont-folder body seed))
+
+ (_ seed))))))
+
+ (define (fun-folder fun seed)
+ (match fun
+ (($ $fun meta free body)
+ (cont-folder body seed))))
+
+ (define (term-folder term seed)
+ (match term
+ (($ $letk conts body)
+ (fold cont-folder (term-folder body seed) conts))
+
+ (($ $continue k exp)
+ (match exp
+ (($ $fun) (fun-folder exp seed))
+ (_ seed)))
+
+ (($ $letrec names syms funs body)
+ (fold fun-folder (term-folder body seed) funs))))
+
+ (fun-folder fun seed))
+
+(define (fold-local-conts proc seed cont)
+ (define (cont-folder cont seed)
+ (match cont
+ (($ $cont k src cont)
+ (let ((seed (proc k src cont seed)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed))
+
+ (($ $kentry self tail clauses)
+ (fold cont-folder (cont-folder tail seed) clauses))
+
+ (($ $kclause arity body)
+ (cont-folder body seed))
+
+ (_ seed))))))
+
+ (define (term-folder term seed)
+ (match term
+ (($ $letk conts body)
+ (fold cont-folder (term-folder body seed) conts))
+
+ (($ $continue) seed)
+
+ (($ $letrec names syms funs body) (term-folder body seed))))
+
+ (cont-folder cont seed))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
new file mode 100644
index 0000000..0276d1d
--- /dev/null
+++ b/module/language/cps/verify.scm
@@ -0,0 +1,165 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;;
+;;; Code:
+
+(define-module (language cps verify)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (verify-cps))
+
+(define (verify-cps fun)
+ (define seen-gensyms (make-hash-table))
+
+ (define (add sym env)
+ (if (hashq-ref seen-gensyms sym)
+ (error "duplicate gensym" sym)
+ (begin
+ (hashq-set! seen-gensyms sym #t)
+ (cons sym env))))
+
+ (define (add-env new env)
+ (if (null? new)
+ env
+ (add-env (cdr new) (add (car new) env))))
+
+ (define (check-var sym env)
+ (cond
+ ((not (hashq-ref seen-gensyms sym))
+ (error "unbound lexical" sym))
+ ((not (memq sym env))
+ (error "displaced lexical" sym))))
+
+ (define (check-src src)
+ (if (and src (not (and (list? src) (and-map pair? src)
+ (and-map symbol? (map car src)))))
+ (error "bad src")))
+
+ (define (visit-cont-body cont k-env v-env)
+ (match cont
+ (($ $kif kt kf)
+ (check-var kt k-env)
+ (check-var kf k-env))
+ (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
+ (check-var k k-env))
+ (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
+ (unless (= (length name) (length sym))
+ (error "name and sym lengths don't match" name sym))
+ (visit-term body k-env (add-env sym v-env)))
+ (_
+ ;; $kclause, $kentry, and $ktail are only ever seen in $fun.
+ (error "unexpected cont body" cont))))
+
+ (define (visit-clause clause k-env v-env)
+ (match clause
+ (($ $cont kclause src*
+ ($ $kclause
+ ($ $arity
+ ((? symbol? req) ...)
+ ((? symbol? opt) ...)
+ (and rest (or #f (? symbol?)))
+ (((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
+ (or #f #t))
+ ($ $cont kbody src (and body ($ $kargs names syms _)))))
+ (check-src src*)
+ (check-src src)
+ (for-each (lambda (sym)
+ (unless (memq sym syms)
+ (error "bad keyword sym" sym)))
+ kwsym)
+ ;; FIXME: It is technically possible for kw syms to alias other
+ ;; syms.
+ (unless (equal? (append req opt (if rest (list rest) '()) kwname)
+ names)
+ (error "clause body names do not match arity names" exp))
+ (let ((k-env (add-env (list kclause kbody) k-env)))
+ (visit-cont-body body k-env v-env)))
+ (_
+ (error "unexpected clause" clause))))
+
+ (define (visit-fun fun k-env v-env)
+ (match fun
+ (($ $fun meta ((? symbol? free) ...)
+ ($ $cont kbody src
+ ($ $kentry (? symbol? self) ($ $cont ktail _ ($ $ktail)) clauses)))
+ (when (and meta (not (and (list? meta) (and-map pair? meta))))
+ (error "meta should be alist" meta))
+ (for-each (cut check-var <> v-env) free)
+ (check-src src)
+ ;; Reset the continuation environment, because Guile's
+ ;; continuations are local.
+ (let ((v-env (add-env (list self) v-env))
+ (k-env (add-env (list ktail) '())))
+ (for-each (cut visit-clause <> k-env v-env) clauses)))
+ (_
+ (error "unexpected $fun" fun))))
+
+ (define (visit-expression exp k-env v-env)
+ (match exp
+ (($ $var sym)
+ (check-var sym v-env))
+ (($ $void)
+ #t)
+ (($ $const val)
+ #t)
+ (($ $prim (? symbol? name))
+ #t)
+ (($ $fun)
+ (visit-fun fun k-env v-env))
+ (($ $call (? symbol? proc) ((? symbol? arg) ...))
+ (check-var proc v-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $primcall (? symbol? name) ((? symbol? arg) ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $values ((? symbol? arg) ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $prompt escape? tag handler)
+ (unless (boolean? escape?) (error "escape? should be boolean" escape?))
+ (check-var tag v-env)
+ (check-var handler k-env))
+ (_
+ (error "unexpected expression" exp))))
+
+ (define (visit-term term k-env v-env)
+ (match term
+ (($ $letk (($ $cont (? symbol? k) src cont) ...) body)
+ (let ((k-env (add-env k k-env)))
+ (for-each check-src src)
+ (for-each (cut visit-cont-body <> k-env v-env) cont)
+ (visit-term body k-env v-env)))
+
+ (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
+ (unless (= (length name) (length sym) (length fun))
+ (error "letrec syms, names, and funs not same length" term))
+ (let ((v-env (add-env sym v-env)))
+ (for-each (cut visit-fun <> k-env v-env) fun)
+ (visit-term body k-env v-env)))
+
+ (($ $continue k exp)
+ (check-var k k-env)
+ (visit-expression exp k-env v-env))
+
+ (_
+ (error "unexpected term" term))))
+
+ (visit-fun fun '() '())
+ fun)
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 2/9] (compile foo #:to 'cps)
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
2013-08-29 7:49 ` [PATCH 1/9] Add CPS language Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 3/9] Add closure conversion Andy Wingo
` (8 subsequent siblings)
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/language/tree-il/compile-cps.scm: New module implementing CPS
conversion of Tree-IL.
* module/Makefile.am:
* module/language/tree-il/spec.scm:
* module/language/cps/spec.scm: Integrate CPS in the build and language
system.
---
module/Makefile.am | 2 +
module/language/cps/spec.scm | 36 ++
module/language/tree-il/compile-cps.scm | 594 ++++++++++++++++++++++++++++++++
module/language/tree-il/spec.scm | 4 +-
4 files changed, 635 insertions(+), 1 deletion(-)
create mode 100644 module/language/cps/spec.scm
create mode 100644 module/language/tree-il/compile-cps.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 1f66ac4..fea910f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -112,12 +112,14 @@ TREE_IL_LANG_SOURCES = \
language/tree-il/canonicalize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
+ language/tree-il/compile-cps.scm \
language/tree-il/compile-glil.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
CPS_LANG_SOURCES = \
language/cps.scm \
+ language/cps/spec.scm \
language/cps/verify.scm
GLIL_LANG_SOURCES = \
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
new file mode 100644
index 0000000..38dc54d
--- /dev/null
+++ b/module/language/cps/spec.scm
@@ -0,0 +1,36 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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
+
+;;; Code:
+
+(define-module (language cps spec)
+ #:use-module (system base language)
+ #:use-module (language cps)
+ #:export (cps))
+
+(define* (write-cps exp #:optional (port (current-output-port)))
+ (write (unparse-cps exp) port))
+
+(define-language cps
+ #:title "CPS Intermediate Language"
+ #:reader (lambda (port env) (read port))
+ #:printer write-cps
+ #:parser parse-cps
+ #:compilers '()
+ #:for-humans? #f
+ )
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
new file mode 100644
index 0000000..e7befbe
--- /dev/null
+++ b/module/language/tree-il/compile-cps.scm
@@ -0,0 +1,594 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;; This pass converts Tree-IL to the continuation-passing style (CPS)
+;;; language.
+;;;
+;;; CPS is a lower-level representation than Tree-IL. Converting to
+;;; CPS, beyond adding names for all control points and all values,
+;;; simplifies expressions in the following ways, among others:
+;;;
+;;; * Fixing the order of evaluation.
+;;;
+;;; * Converting assigned variables to boxed variables.
+;;;
+;;; * Requiring that Scheme's <letrec> has already been lowered to
+;;; <fix>.
+;;;
+;;; * Inlining default-value initializers into lambda-case
+;;; expressions.
+;;;
+;;; * Inlining prompt bodies.
+;;;
+;;; * Turning toplevel and module references into primcalls. This
+;;; involves explicitly modelling the "scope" of toplevel lookups
+;;; (indicating the module with respect to which toplevel bindings
+;;; are resolved).
+;;;
+;;; The utility of CPS is that it gives a name to everything: every
+;;; intermediate value, and every control point (continuation). As such
+;;; it is more verbose than Tree-IL, but at the same time more simple as
+;;; the number of concepts is reduced.
+;;;
+;;; Code:
+
+(define-module (language tree-il compile-cps)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
+ #:use-module (srfi srfi-26)
+ #:use-module ((system foreign) #:select (make-pointer pointer->scm))
+ #:use-module (language cps)
+ #:use-module (language cps primitives)
+ #:use-module (language tree-il analyze)
+ #:use-module (language tree-il optimize)
+ #:use-module ((language tree-il)
+ #:select
+ (<void>
+ <const> <primitive-ref> <lexical-ref> <lexical-set>
+ <module-ref> <module-set>
+ <toplevel-ref> <toplevel-set> <toplevel-define>
+ <conditional>
+ <call> <primcall>
+ <seq>
+ <lambda> <lambda-case>
+ <let> <letrec> <fix> <let-values>
+ <prompt> <abort>
+ make-conditional make-const make-primcall
+ tree-il-src
+ tree-il-fold))
+ #:export (compile-cps))
+
+;;; Guile's semantics are that a toplevel lambda captures a reference on
+;;; the current module, and that all contained lambdas use that module
+;;; to resolve toplevel variables. This parameter tracks whether or not
+;;; we are in a toplevel lambda. If we are in a lambda, the parameter
+;;; is bound to a fresh name identifying the module that was current
+;;; when the toplevel lambda is defined.
+;;;
+;;; This is more complicated than it need be. Ideally we should resolve
+;;; all toplevel bindings to bindings from specific modules, unless the
+;;; binding is unbound. This is always valid if the compilation unit
+;;; sets the module explicitly, as when compiling a module, but it
+;;; doesn't work for files auto-compiled for use with `load'.
+;;;
+(define current-topbox-scope (make-parameter #f))
+
+(define (toplevel-box src name bound? val-proc)
+ (let-gensyms (name-sym bound?-sym kbox box)
+ (build-cps-term
+ ($letconst (('name name-sym name)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ,(match (current-topbox-scope)
+ (#f
+ (build-cps-term
+ ($continue kbox
+ ($primcall 'resolve
+ (name-sym bound?-sym)))))
+ (scope
+ (let-gensyms (scope-sym)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope))
+ ($continue kbox
+ ($primcall 'cached-toplevel-box
+ (scope-sym name-sym bound?-sym)))))))))))))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (build-cps-term
+ ($letconst (('module module-sym module)
+ ('name name-sym name)
+ ('public? public?-sym public?)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox
+ ($primcall 'cached-module-box
+ (module-sym name-sym public?-sym bound?-sym))))))))
+
+(define (capture-toplevel-scope src scope k)
+ (let-gensyms (module scope-sym kmodule)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope))
+ ($letk ((kmodule src ($kargs ('module) (module)
+ ($continue k
+ ($primcall 'cache-current-module!
+ (module scope-sym))))))
+ ($continue kmodule
+ ($primcall 'current-module ())))))))
+
+(define (fold-formals proc seed arity gensyms inits)
+ (match arity
+ (($ $arity req opt rest kw allow-other-keys?)
+ (let ()
+ (define (fold-req names gensyms seed)
+ (match names
+ (() (fold-opt opt gensyms inits seed))
+ ((name . names)
+ (proc name (car gensyms) #f
+ (fold-req names (cdr gensyms) seed)))))
+ (define (fold-opt names gensyms inits seed)
+ (match names
+ (() (fold-rest rest gensyms inits seed))
+ ((name . names)
+ (proc name (car gensyms) (car inits)
+ (fold-opt names (cdr gensyms) (cdr inits) seed)))))
+ (define (fold-rest rest gensyms inits seed)
+ (match rest
+ (#f (fold-kw kw gensyms inits seed))
+ (name (proc name (car gensyms) #f
+ (fold-kw kw (cdr gensyms) inits seed)))))
+ (define (fold-kw kw gensyms inits seed)
+ (match kw
+ (()
+ (unless (null? gensyms)
+ (error "too many gensyms"))
+ (unless (null? inits)
+ (error "too many inits"))
+ seed)
+ (((key name var) . kw)
+ (unless (eq? var (car gensyms))
+ (error "unexpected keyword arg order"))
+ (proc name var (car inits)
+ (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
+ (fold-req req gensyms seed)))))
+
+(define (unbound? src sym kt kf)
+ (define tc8-iflag 4)
+ (define unbound-val 9)
+ (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
+ (let-gensyms (unbound ktest)
+ (build-cps-term
+ ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
+ ($letk ((ktest src ($kif kt kf)))
+ ($continue ktest
+ ($primcall 'eq? (sym unbound))))))))
+
+(define (init-default-value name sym subst init body)
+ (match (assq-ref subst sym)
+ ((subst-sym box?)
+ (let ((src (tree-il-src init)))
+ (define (maybe-box k make-body)
+ (if box?
+ (let-gensyms (kbox phi)
+ (build-cps-term
+ ($letk ((kbox src ($kargs (name) (phi)
+ ($continue k ($primcall 'box (phi))))))
+ ,(make-body kbox))))
+ (make-body k)))
+ (let-gensyms (knext kbound kunbound)
+ (build-cps-term
+ ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+ ,(maybe-box
+ knext
+ (lambda (k)
+ (build-cps-term
+ ($letk ((kbound src ($kargs () () ($continue k ($var sym))))
+ (kunbound src ($kargs () () ,(convert init k subst))))
+ ,(unbound? src sym kunbound kbound))))))))))))
+
+;; exp k-name alist -> term
+(define (convert exp k subst)
+ ;; exp (v-name -> term) -> term
+ (define (convert-arg exp k)
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (match (assq-ref subst sym)
+ ((box #t)
+ (let-gensyms (kunboxed unboxed)
+ (build-cps-term
+ ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+ ($continue kunboxed ($primcall 'box-ref (box)))))))
+ ((subst #f) (k subst))
+ (#f (k sym))))
+ (else
+ (let ((src (tree-il-src exp)))
+ (let-gensyms (karg arg)
+ (build-cps-term
+ ($letk ((karg src ($kargs ('arg) (arg) ,(k arg))))
+ ,(convert exp karg subst))))))))
+ ;; (exp ...) ((v-name ...) -> term) -> term
+ (define (convert-args exps k)
+ (match exps
+ (() (k '()))
+ ((exp . exps)
+ (convert-arg exp
+ (lambda (name)
+ (convert-args exps
+ (lambda (names)
+ (k (cons name names)))))))))
+ (define (box-bound-var name sym body)
+ (match (assq-ref subst sym)
+ ((box #t)
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k #f ($kargs (name) (box) ,body)))
+ ($continue k ($primcall 'box (sym)))))))
+ (else body)))
+
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (match (assq-ref subst sym)
+ ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box)))))
+ ((subst #f) (build-cps-term ($continue k ($var subst))))
+ (#f (build-cps-term ($continue k ($var sym))))))
+
+ (($ <void> src)
+ (build-cps-term ($continue k ($void))))
+
+ (($ <const> src exp)
+ (build-cps-term ($continue k ($const exp))))
+
+ (($ <primitive-ref> src name)
+ (build-cps-term ($continue k ($prim name))))
+
+ (($ <lambda> fun-src meta body)
+ (let ()
+ (define (convert-clauses body ktail)
+ (match body
+ (#f '())
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (let* ((arity (make-$arity req (or opt '()) rest
+ (if kw (cdr kw) '()) (and kw (car kw))))
+ (names (fold-formals (lambda (name sym init names)
+ (cons name names))
+ '()
+ arity gensyms inits)))
+ (cons
+ (let-gensyms (kclause kargs)
+ (build-cps-cont
+ (kclause
+ src
+ ($kclause ,arity
+ (kargs
+ src
+ ($kargs names gensyms
+ ,(fold-formals
+ (lambda (name sym init body)
+ (if init
+ (init-default-value name sym subst init body)
+ (box-bound-var name sym body)))
+ (convert body ktail subst)
+ arity gensyms inits)))))))
+ (convert-clauses alternate ktail))))))
+ (if (current-topbox-scope)
+ (let-gensyms (kentry self ktail)
+ (build-cps-term
+ ($continue k
+ ($fun meta '()
+ (kentry fun-src
+ ($kentry self (ktail #f ($ktail))
+ ,(convert-clauses body ktail)))))))
+ (let-gensyms (scope kscope)
+ (build-cps-term
+ ($letk ((kscope fun-src
+ ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope fun-src scope kscope)))))))
+
+ (($ <module-ref> src mod name public?)
+ (module-box
+ src mod name public? #t
+ (lambda (box)
+ (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+
+ (($ <module-set> src mod name public? exp)
+ (convert-arg exp
+ (lambda (val)
+ (module-box
+ src mod name public? #f
+ (lambda (box)
+ (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+
+ (($ <toplevel-ref> src name)
+ (toplevel-box
+ src name #t
+ (lambda (box)
+ (build-cps-term ($continue k ($primcall 'box-ref (box)))))))
+
+ (($ <toplevel-set> src name exp)
+ (convert-arg exp
+ (lambda (val)
+ (toplevel-box
+ src name #f
+ (lambda (box)
+ (build-cps-term ($continue k ($primcall 'box-set! (box val)))))))))
+
+ (($ <toplevel-define> src name exp)
+ (convert-arg exp
+ (lambda (val)
+ (let-gensyms (kname name-sym)
+ (build-cps-term
+ ($letconst (('name name-sym name))
+ ($continue k ($primcall 'define! (name-sym val)))))))))
+
+ (($ <call> src proc args)
+ (convert-args (cons proc args)
+ (match-lambda
+ ((proc . args)
+ (build-cps-term ($continue k ($call proc args)))))))
+
+ (($ <primcall> src name args)
+ (case name
+ ((list)
+ (convert (fold-right (lambda (elem tail)
+ (make-primcall src 'cons
+ (list elem tail)))
+ (make-const src '())
+ args)
+ k subst))
+ (else
+ (if (branching-primitive? name)
+ (convert (make-conditional src exp (make-const #f #t)
+ (make-const #f #f))
+ k subst)
+ (convert-args args
+ (lambda (args)
+ (if (eq? name 'values)
+ (build-cps-term ($continue k ($values args)))
+ (build-cps-term ($continue k ($primcall name args))))))))))
+
+ ;; Prompts with inline handlers.
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ ;; Handler:
+ ;; khargs: check args returned to handler, -> khbody
+ ;; khbody: the handler, -> k
+ ;;
+ ;; Post-body:
+ ;; krest: collect return vals from body to list, -> kpop
+ ;; kpop: pop the prompt, -> kprim
+ ;; kprim: load the values primitive, -> kret
+ ;; kret: (apply values rvals), -> k
+ ;;
+ ;; Escape prompts evaluate the body with the continuation of krest.
+ ;; Otherwise we do a no-inline call to body, continuing to krest.
+ (convert-arg tag
+ (lambda (tag)
+ (let ((hnames (append hreq (if hrest (list hrest) '()))))
+ (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+ (build-cps-term
+ ($letk* ((khbody hsrc ($kargs hnames hsyms
+ ,(fold box-bound-var
+ (convert hbody k subst)
+ hnames hsyms)))
+ (khargs hsrc ($ktrunc hreq hrest khbody))
+ (kpop src
+ ($kargs ('rest) (vals)
+ ($letk ((kret
+ src
+ ($kargs () ()
+ ($letk ((kprim
+ src
+ ($kargs ('prim) (prim)
+ ($continue k
+ ($primcall 'apply
+ (prim vals))))))
+ ($continue kprim
+ ($prim 'values))))))
+ ($continue kret
+ ($primcall 'pop-prompt ())))))
+ (krest src ($ktrunc '() 'rest kpop)))
+ ,(if escape-only?
+ (build-cps-term
+ ($letk ((kbody (tree-il-src body)
+ ($kargs () ()
+ ,(convert body krest subst))))
+ ($continue kbody ($prompt #t tag khargs))))
+ (convert-arg body
+ (lambda (thunk)
+ (build-cps-term
+ ($letk ((kbody (tree-il-src body)
+ ($kargs () ()
+ ($continue krest
+ ($primcall 'call-thunk/no-inline
+ (thunk))))))
+ ($continue kbody
+ ($prompt #f tag khargs))))))))))))))
+
+ ;; Eta-convert prompts without inline handlers.
+ (($ <prompt> src escape-only? tag body handler)
+ (convert-args (list tag body handler)
+ (lambda (args)
+ (build-cps-term
+ ($continue k ($primcall 'call-with-prompt args))))))
+
+ (($ <abort> src tag args tail)
+ (convert-args (append (list tag) args (list tail))
+ (lambda (args*)
+ (build-cps-term ($continue k ($primcall 'abort args*))))))
+
+ (($ <conditional> src test consequent alternate)
+ (let-gensyms (kif kt kf)
+ (build-cps-term
+ ($letk* ((kt (tree-il-src consequent) ($kargs () ()
+ ,(convert consequent k subst)))
+ (kf (tree-il-src alternate) ($kargs () ()
+ ,(convert alternate k subst)))
+ (kif src ($kif kt kf)))
+ ,(match test
+ (($ <primcall> src (? branching-primitive? name) args)
+ (convert-args args
+ (lambda (args)
+ (build-cps-term ($continue kif ($primcall name args))))))
+ (_ (convert-arg test
+ (lambda (test)
+ (build-cps-term ($continue kif ($var test)))))))))))
+
+ (($ <lexical-set> src name gensym exp)
+ (convert-arg exp
+ (lambda (exp)
+ (match (assq-ref subst gensym)
+ ((box #t)
+ (build-cps-term
+ ($continue k ($primcall 'box-set! (box exp)))))))))
+
+ (($ <seq> src head tail)
+ (let-gensyms (ktrunc kseq)
+ (build-cps-term
+ ($letk* ((kseq (tree-il-src tail) ($kargs () ()
+ ,(convert tail k subst)))
+ (ktrunc src ($ktrunc '() #f kseq)))
+ ,(convert head ktrunc subst)))))
+
+ (($ <let> src names syms vals body)
+ (let lp ((names names) (syms syms) (vals vals))
+ (match (list names syms vals)
+ ((() () ()) (convert body k subst))
+ (((name . names) (sym . syms) (val . vals))
+ (let-gensyms (klet)
+ (build-cps-term
+ ($letk ((klet src ($kargs (name) (sym)
+ ,(box-bound-var name sym
+ (lp names syms vals)))))
+ ,(convert val klet subst))))))))
+
+ (($ <fix> src names gensyms funs body)
+ ;; Some letrecs can be contified; that happens later.
+ (if (current-topbox-scope)
+ (let-gensyms (self)
+ (build-cps-term
+ ($letrec names
+ gensyms
+ (map (lambda (fun)
+ (match (convert fun k subst)
+ (($ $continue _ (and fun ($ $fun)))
+ fun)))
+ funs)
+ ,(convert body k subst))))
+ (let-gensyms (scope kscope)
+ (build-cps-term
+ ($letk ((kscope src ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope kscope))))))
+
+ (($ <let-values> src exp
+ ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ (let ((names (append req (if rest (list rest) '()))))
+ (let-gensyms (ktrunc kargs)
+ (build-cps-term
+ ($letk* ((kargs src ($kargs names syms
+ ,(fold box-bound-var
+ (convert body k subst)
+ names syms)))
+ (ktrunc src ($ktrunc req rest kargs)))
+ ,(convert exp ktrunc subst))))))))
+
+(define (build-subst exp)
+ "Compute a mapping from lexical gensyms to substituted gensyms. The
+usual reason to replace one variable by another is assignment
+conversion. Default argument values is the other reason.
+
+Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED?
+indicates that the replacement variable is in a box."
+ (define (box-set-vars exp subst)
+ (match exp
+ (($ <lexical-set> src name sym exp)
+ (if (assq sym subst)
+ subst
+ (cons (list sym (gensym "b") #t) subst)))
+ (_ subst)))
+ (define (default-args exp subst)
+ (match exp
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (fold-formals (lambda (name sym init subst)
+ (if init
+ (let ((box? (match (assq-ref subst sym)
+ ((box #t) #t)
+ (#f #f)))
+ (subst-sym (gensym (symbol->string name))))
+ (cons (list sym subst-sym box?) subst))
+ subst))
+ subst
+ (make-$arity req (or opt '()) rest
+ (if kw (cdr kw) '()) (and kw (car kw)))
+ gensyms
+ inits))
+ (_ subst)))
+ (tree-il-fold box-set-vars default-args '() exp))
+
+(define (cps-convert/thunk exp)
+ (let ((src (tree-il-src exp)))
+ (let-gensyms (kinit init ktail kclause kbody)
+ (build-cps-exp
+ ($fun '() '()
+ (kinit src
+ ($kentry init
+ (ktail #f ($ktail))
+ ((kclause src
+ ($kclause ('() '() #f '() #f)
+ (kbody src
+ ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))))))))))))
+
+(define *comp-module* (make-fluid))
+
+(define %warning-passes
+ `((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
+ (unbound-variable . ,unbound-variable-analysis)
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
+
+(define (optimize-tree-il x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
+ ;; Go through the warning passes.
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
+
+ (optimize x e opts))
+
+(define (compile-cps exp env opts)
+ (values (cps-convert/thunk (optimize-tree-il exp env opts))
+ env
+ env))
+
+;;; Local Variables:
+;;; eval: (put 'convert-arg 'scheme-indent-function 1)
+;;; eval: (put 'convert-args 'scheme-indent-function 1)
+;;; End:
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 80c32fe..a574eb2 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -23,6 +23,7 @@
#:use-module (system base pmatch)
#:use-module (language glil)
#:use-module (language tree-il)
+ #:use-module (language tree-il compile-cps)
#:use-module (language tree-il compile-glil)
#:export (tree-il))
@@ -43,6 +44,7 @@
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
- #:compilers `((glil . ,compile-glil))
+ #:compilers `((glil . ,compile-glil)
+ (cps . ,compile-cps))
#:for-humans? #f
)
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 3/9] Add closure conversion
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
2013-08-29 7:49 ` [PATCH 1/9] Add CPS language Andy Wingo
2013-08-29 7:49 ` [PATCH 2/9] (compile foo #:to 'cps) Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 4/9] RTL language Andy Wingo
` (7 subsequent siblings)
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am
* module/language/cps/closure-conversion.scm: New module, implementing a
closure conversion pass.
---
module/Makefile.am | 1 +
module/language/cps/closure-conversion.scm | 273 +++++++++++++++++++++++++++++
2 files changed, 274 insertions(+)
create mode 100644 module/language/cps/closure-conversion.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index fea910f..6fd88e6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -119,6 +119,7 @@ TREE_IL_LANG_SOURCES = \
CPS_LANG_SOURCES = \
language/cps.scm \
+ language/cps/closure-conversion.scm \
language/cps/spec.scm \
language/cps/verify.scm
diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm
new file mode 100644
index 0000000..9a9738b
--- /dev/null
+++ b/module/language/cps/closure-conversion.scm
@@ -0,0 +1,273 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;; This pass converts a CPS term in such a way that no function has any
+;;; free variables. Instead, closures are built explicitly with
+;;; make-closure primcalls, and free variables are referenced through
+;;; the closure.
+;;;
+;;; Closure conversion also removes any $letrec forms that contification
+;;; did not handle. See (language cps) for a further discussion of
+;;; $letrec.
+;;;
+;;; Code:
+
+(define-module (language cps closure-conversion)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold
+ lset-union lset-difference
+ list-index))
+ #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (convert-closures))
+
+(define (union s1 s2)
+ (lset-union eq? s1 s2))
+
+(define (difference s1 s2)
+ (lset-difference eq? s1 s2))
+
+;; bound := sym ...
+;; free := sym ...
+
+(define (convert-free-var sym self bound k)
+ "Convert one possibly free variable reference to a bound reference.
+
+If @var{sym} is free (i.e., not present in @var{bound},), it is replaced
+by a closure reference via a @code{free-ref} primcall, and @var{k} is
+called with the new var. Otherwise @var{sym} is bound, so @var{k} is
+called with @var{sym}.
+
+@var{k} should return two values: a term and a list of additional free
+values in the term."
+ (if (memq sym bound)
+ (k sym)
+ (let-gensyms (k* sym*)
+ (receive (exp free) (k sym*)
+ (values (build-cps-term
+ ($letk ((k* #f ($kargs (sym*) (sym*) ,exp)))
+ ($continue k* ($primcall 'free-ref (self sym)))))
+ (cons sym free))))))
+
+(define (convert-free-vars syms self bound k)
+ "Convert a number of possibly free references to bound references.
+@var{k} is called with the bound references, and should return two
+values: the term and a list of additional free variables in the term."
+ (match syms
+ (() (k '()))
+ ((sym . syms)
+ (convert-free-var sym self bound
+ (lambda (sym)
+ (convert-free-vars syms self bound
+ (lambda (syms)
+ (k (cons sym syms)))))))))
+
+(define (init-closure src v free outer-self outer-bound body)
+ "Initialize the free variables @var{free} in a closure bound to
+@var{v}, and continue with @var{body}. @var{outer-self} must be the
+label of the outer procedure, where the initialization will be
+performed, and @var{outer-bound} is the list of bound variables there."
+ (fold (lambda (free idx body)
+ (let-gensyms (k idxsym)
+ (build-cps-term
+ ($letk ((k src ($kargs () () ,body)))
+ ,(convert-free-var
+ free outer-self outer-bound
+ (lambda (free)
+ (values (build-cps-term
+ ($letconst (('idx idxsym idx))
+ ($continue k
+ ($primcall 'free-set! (v idxsym free)))))
+ '())))))))
+ body
+ free
+ (iota (length free))))
+
+(define (cc* exps self bound)
+ "Convert all free references in the list of expressions @var{exps} to
+bound references, and convert functions to flat closures. Returns two
+values: the transformed list, and a cumulative set of free variables."
+ (let lp ((exps exps) (exps* '()) (free '()))
+ (match exps
+ (() (values (reverse exps*) free))
+ ((exp . exps)
+ (receive (exp* free*) (cc exp self bound)
+ (lp exps (cons exp* exps*) (union free free*)))))))
+
+;; Closure conversion.
+(define (cc exp self bound)
+ "Convert all free references in @var{exp} to bound references, and
+convert functions to flat closures."
+ (match exp
+ (($ $letk conts body)
+ (receive (conts free) (cc* conts self bound)
+ (receive (body free*) (cc body self bound)
+ (values (build-cps-term ($letk ,conts ,body))
+ (union free free*)))))
+
+ (($ $cont sym src ($ $kargs names syms body))
+ (receive (body free) (cc body self (append syms bound))
+ (values (build-cps-cont (sym src ($kargs names syms ,body)))
+ free)))
+
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (receive (clauses free) (cc* clauses self (list self))
+ (values (build-cps-cont (sym src ($kentry self ,tail ,clauses)))
+ free)))
+
+ (($ $cont sym src ($ $kclause arity body))
+ (receive (body free) (cc body self bound)
+ (values (build-cps-cont (sym src ($kclause ,arity ,body)))
+ free)))
+
+ (($ $cont)
+ ;; Other kinds of continuations don't bind values and don't have
+ ;; bodies.
+ (values exp '()))
+
+ ;; Remove letrec.
+ (($ $letrec names syms funs body)
+ (let ((bound (append bound syms)))
+ (receive (body free) (cc body self bound)
+ (let lp ((in (map list names syms funs))
+ (bindings (lambda (body) body))
+ (body body)
+ (free free))
+ (match in
+ (() (values (bindings body) free))
+ (((name sym ($ $fun meta () fun-body)) . in)
+ (receive (fun-body fun-free) (cc fun-body #f '())
+ (lp in
+ (lambda (body)
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k #f ($kargs (name) (sym) ,(bindings body))))
+ ($continue k
+ ($fun meta fun-free ,fun-body))))))
+ (init-closure #f sym fun-free self bound body)
+ (union free (difference fun-free bound))))))))))
+
+ (($ $continue k ($ $var sym))
+ (convert-free-var sym self bound
+ (lambda (sym)
+ (values (build-cps-term ($continue k ($var sym)))
+ '()))))
+
+ (($ $continue k
+ (or ($ $void)
+ ($ $const)
+ ($ $prim)))
+ (values exp '()))
+
+ (($ $continue k ($ $fun meta () body))
+ (receive (body free) (cc body #f '())
+ (match free
+ (()
+ (values (build-cps-term
+ ($continue k ($fun meta free ,body)))
+ free))
+ (_
+ (values
+ (let-gensyms (kinit v)
+ (build-cps-term
+ ($letk ((kinit #f ($kargs (v) (v)
+ ,(init-closure #f v free self bound
+ (build-cps-term
+ ($continue k ($var v)))))))
+ ($continue kinit ($fun meta free ,body)))))
+ (difference free bound))))))
+
+ (($ $continue k ($ $call proc args))
+ (convert-free-vars (cons proc args) self bound
+ (match-lambda
+ ((proc . args)
+ (values (build-cps-term
+ ($continue k ($call proc args)))
+ '())))))
+
+ (($ $continue k ($ $primcall name args))
+ (convert-free-vars args self bound
+ (lambda (args)
+ (values (build-cps-term
+ ($continue k ($primcall name args)))
+ '()))))
+
+ (($ $continue k ($ $values args))
+ (convert-free-vars args self bound
+ (lambda (args)
+ (values (build-cps-term
+ ($continue k ($values args)))
+ '()))))
+
+ (($ $continue k ($ $prompt escape? tag handler))
+ (convert-free-var
+ tag self bound
+ (lambda (tag)
+ (values (build-cps-term
+ ($continue k ($prompt escape? tag handler)))
+ '()))))
+
+ (_ (error "what" exp))))
+
+;; Convert the slot arguments of 'free-ref' primcalls from symbols to
+;; indices.
+(define (convert-to-indices body free)
+ (define (free-index sym)
+ (or (list-index (cut eq? <> sym) free)
+ (error "free variable not found!" sym free)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $continue k ($ $primcall 'free-ref (closure sym)))
+ ,(let-gensyms (idx)
+ (build-cps-term
+ ($letconst (('idx idx (free-index sym)))
+ ($continue k ($primcall 'free-ref (closure idx)))))))
+ (($ $continue k ($ $fun meta free body))
+ ($continue k ($fun meta free ,(convert-to-indices body free))))
+ (($ $continue)
+ ,term)))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kclause arity body))
+ (sym src ($kclause ,arity ,(visit-cont body))))
+ ;; Other kinds of continuations don't bind values and don't have
+ ;; bodies.
+ (($ $cont)
+ ,cont)))
+
+ (rewrite-cps-cont body
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (sym src ($kentry self ,tail ,(map visit-cont clauses))))))
+
+(define (convert-closures exp)
+ "Convert free reference in @var{exp} to primcalls to @code{free-ref},
+and allocate and initialize flat closures."
+ (match exp
+ (($ $fun meta () body)
+ (receive (body free) (cc body #f '())
+ (unless (null? free)
+ (error "Expected no free vars in toplevel thunk" exp body free))
+ (build-cps-exp
+ ($fun meta free ,(convert-to-indices body free)))))))
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 4/9] RTL language
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (2 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 3/9] Add closure conversion Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 5/9] Add CPS primitives info module Andy Wingo
` (6 subsequent siblings)
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am
* module/language/rtl.scm:
* module/language/rtl/spec.scm: Add a stub RTL language.
---
module/Makefile.am | 5 +++
module/language/rtl.scm | 92 ++++++++++++++++++++++++++++++++++++++++++++
module/language/rtl/spec.scm | 31 +++++++++++++++
3 files changed, 128 insertions(+)
create mode 100644 module/language/rtl.scm
create mode 100644 module/language/rtl/spec.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 6fd88e6..e2268a8 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -54,6 +54,7 @@ SOURCES = \
language/assembly.scm \
$(TREE_IL_LANG_SOURCES) \
$(CPS_LANG_SOURCES) \
+ $(RTL_LANG_SOURCES) \
$(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
@@ -123,6 +124,10 @@ CPS_LANG_SOURCES = \
language/cps/spec.scm \
language/cps/verify.scm
+RTL_LANG_SOURCES = \
+ language/rtl.scm \
+ language/rtl/spec.scm
+
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm
diff --git a/module/language/rtl.scm b/module/language/rtl.scm
new file mode 100644
index 0000000..d217517
--- /dev/null
+++ b/module/language/rtl.scm
@@ -0,0 +1,92 @@
+;;; Register Transfer Language (RTL)
+
+;; Copyright (C) 2013 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
+
+;;; Code:
+
+(define-module (language rtl)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (system vm instruction)
+ #:re-export (rtl-instruction-list)
+ #:export (rtl-instruction-arity))
+
+(define (compute-rtl-instruction-arity name args)
+ (define (first-word-arity word)
+ (case word
+ ((U8_X24) 0)
+ ((U8_U24) 1)
+ ((U8_L24) 1)
+ ((U8_U8_I16) 2)
+ ((U8_U12_U12) 2)
+ ((U8_U8_U8_U8) 3)))
+ (define (tail-word-arity word)
+ (case word
+ ((U8_U24) 2)
+ ((U8_L24) 2)
+ ((U8_U8_I16) 3)
+ ((U8_U12_U12) 3)
+ ((U8_U8_U8_U8) 4)
+ ((U32) 1)
+ ((I32) 1)
+ ((A32) 1)
+ ((B32) 0)
+ ((N32) 1)
+ ((S32) 1)
+ ((L32) 1)
+ ((LO32) 1)
+ ((X8_U24) 1)
+ ((X8_U12_U12) 2)
+ ((X8_L24) 1)
+ ((B1_X7_L24) 2)
+ ((B1_U7_L24) 3)
+ ((B1_X31) 1)
+ ((B1_X7_U24) 2)))
+ (match args
+ ((arg0 . args)
+ (fold (lambda (arg arity)
+ (+ (tail-word-arity arg) arity))
+ (first-word-arity arg0)
+ args))))
+
+(define *macro-instruction-arities*
+ '((cache-current-module! . (0 . 2))
+ (cached-toplevel-box . (1 . 3))
+ (cached-module-box . (1 . 4))))
+
+(define (compute-rtl-instruction-arities)
+ (let ((table (make-hash-table)))
+ (for-each
+ (match-lambda
+ ;; Put special cases here.
+ ((name op '! . args)
+ (hashq-set! table name
+ (cons 0 (compute-rtl-instruction-arity name args))))
+ ((name op '<- . args)
+ (hashq-set! table name
+ (cons 1 (1- (compute-rtl-instruction-arity name args))))))
+ (rtl-instruction-list))
+ (for-each (match-lambda
+ ((name . arity)
+ (hashq-set! table name arity)))
+ *macro-instruction-arities*)
+ table))
+
+(define *rtl-instruction-arities* (delay (compute-rtl-instruction-arities)))
+
+(define (rtl-instruction-arity name)
+ (hashq-ref (force *rtl-instruction-arities*) name))
diff --git a/module/language/rtl/spec.scm b/module/language/rtl/spec.scm
new file mode 100644
index 0000000..0a8c4ee
--- /dev/null
+++ b/module/language/rtl/spec.scm
@@ -0,0 +1,31 @@
+;;; Register Transfer Language (RTL)
+
+;; Copyright (C) 2013 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
+
+;;; Code:
+
+(define-module (language rtl spec)
+ #:use-module (system base language)
+ #:use-module (ice-9 binary-ports)
+ #:export (rtl))
+
+(define-language rtl
+ #:title "Register Transfer Language"
+ #:compilers '()
+ #:printer (lambda (rtl port) (put-bytevector port rtl))
+ #:reader get-bytevector-all
+ #:for-humans? #f)
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 5/9] Add CPS primitives info module
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (3 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 4/9] RTL language Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 6/9] Add arity-adapting module Andy Wingo
` (5 subsequent siblings)
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am:
* module/language/cps/primitives.scm: New file.
---
module/Makefile.am | 1 +
module/language/cps/primitives.scm | 96 ++++++++++++++++++++++++++++++++++++++
2 files changed, 97 insertions(+)
create mode 100644 module/language/cps/primitives.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index e2268a8..790db8c 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -121,6 +121,7 @@ TREE_IL_LANG_SOURCES = \
CPS_LANG_SOURCES = \
language/cps.scm \
language/cps/closure-conversion.scm \
+ language/cps/primitives.scm \
language/cps/spec.scm \
language/cps/verify.scm
diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm
new file mode 100644
index 0000000..1c683e2
--- /dev/null
+++ b/module/language/cps/primitives.scm
@@ -0,0 +1,96 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;; Information about named primitives, as they appear in $prim and $primcall.
+;;;
+;;; Code:
+
+(define-module (language cps primitives)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-26)
+ #:use-module (language rtl)
+ #:export (prim-rtl-instruction
+ branching-primitive?
+ prim-arity
+ ))
+
+(define *rtl-instruction-aliases*
+ '((+ . add) (1+ . add1)
+ (- . sub) (1- . sub1)
+ (* . mul) (/ . div)
+ (quotient . quo) (remainder . rem)
+ (modulo . mod)
+ (define! . define)
+ (vector-set! . vector-set)))
+
+(define *macro-instruction-arities*
+ '((cache-current-module! . (0 . 2))
+ (cached-toplevel-box . (1 . 3))
+ (cached-module-box . (1 . 4))))
+
+(define *branching-primcall-arities*
+ '((null? . (1 . 1))
+ (nil? . (1 . 1))
+ (pair? . (1 . 1))
+ (struct? . (1 . 1))
+ (char? . (1 . 1))
+ (eq? . (1 . 2))
+ (eqv? . (1 . 2))
+ (equal? . (1 . 2))
+ (= . (1 . 2))
+ (< . (1 . 2))
+ (> . (1 . 2))
+ (<= . (1 . 2))
+ (>= . (1 . 2))))
+
+(define (compute-prim-rtl-instructions)
+ (let ((table (make-hash-table)))
+ (for-each
+ (match-lambda ((inst . _) (hashq-set! table inst inst)))
+ (rtl-instruction-list))
+ (for-each
+ (match-lambda ((prim . inst) (hashq-set! table prim inst)))
+ *rtl-instruction-aliases*)
+ (for-each
+ (match-lambda ((inst . arity) (hashq-set! table inst inst)))
+ *macro-instruction-arities*)
+ table))
+
+(define *prim-rtl-instructions* (delay (compute-prim-rtl-instructions)))
+
+;; prim -> rtl-instruction | #f
+(define (prim-rtl-instruction name)
+ (hashq-ref (force *prim-rtl-instructions*) name))
+
+(define (branching-primitive? name)
+ (and (assq name *branching-primcall-arities*) #t))
+
+(define *prim-arities* (make-hash-table))
+
+(define (prim-arity name)
+ (or (hashq-ref *prim-arities* name)
+ (let ((arity (cond
+ ((prim-rtl-instruction name) => rtl-instruction-arity)
+ ((assq name *branching-primcall-arities*) => cdr)
+ (else
+ (error "Primitive of unknown arity" name)))))
+ (hashq-set! *prim-arities* name arity)
+ arity)))
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 6/9] Add arity-adapting module
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (4 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 5/9] Add CPS primitives info module Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 21:08 ` Ludovic Courtès
2013-08-29 7:49 ` [PATCH 7/9] Add pass to reify primcalls without corresponding VM ops Andy Wingo
` (4 subsequent siblings)
10 siblings, 1 reply; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am:
* module/language/cps/arities.scm: New module. Adapts call and return
arities, especially for primcalls.
---
module/Makefile.am | 1 +
module/language/cps/arities.scm | 152 ++++++++++++++++++++++++++++++++++++++++
2 files changed, 153 insertions(+)
create mode 100644 module/language/cps/arities.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 790db8c..bcef4bf 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -120,6 +120,7 @@ TREE_IL_LANG_SOURCES = \
CPS_LANG_SOURCES = \
language/cps.scm \
+ language/cps/arities.scm \
language/cps/closure-conversion.scm \
language/cps/primitives.scm \
language/cps/spec.scm \
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
new file mode 100644
index 0000000..b697ec0
--- /dev/null
+++ b/module/language/cps/arities.scm
@@ -0,0 +1,152 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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 adapt expressions to the arities of their continuations,
+;;; and to rewrite some tail expressions as primcalls to "return".
+;;;
+;;; Code:
+
+(define-module (language cps arities)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:export (fix-arities))
+
+(define (fix-clause-arities clause)
+ (let ((conts (build-local-cont-table clause))
+ (ktail (match clause
+ (($ $cont _ _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map fix-arities funs) ,(visit-term body)))
+ (($ $continue k exp)
+ ,(visit-exp k exp))))
+
+ (define (adapt-exp nvals k exp)
+ (match nvals
+ (0
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(let-gensyms (kvoid kunspec unspec)
+ (build-cps-term
+ ($letk* ((kunspec #f ($kargs (unspec) (unspec)
+ ($continue k
+ ($primcall 'return (unspec)))))
+ (kvoid #f ($kargs () ()
+ ($continue kunspec ($void)))))
+ ($continue kvoid ,exp)))))
+ (($ $ktrunc ($ $arity () () #f () #f) kseq)
+ ($continue kseq ,exp))
+ (($ $kargs () () _)
+ ($continue k ,exp))
+ (_
+ ,(let-gensyms (k*)
+ (build-cps-term
+ ($letk ((k* #f ($kargs () () ($continue k ($void)))))
+ ($continue k* ,exp)))))))
+ (1
+ (let ((drop-result
+ (lambda (kseq)
+ (let-gensyms (k* drop)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('drop) (drop)
+ ($continue kseq ($values ())))))
+ ($continue k* ,exp)))))))
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(rewrite-cps-term exp
+ (($var sym)
+ ($continue ktail ($primcall 'return (sym))))
+ (_
+ ,(let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k
+ ($primcall 'return (v))))))
+ ($continue k* ,exp)))))))
+ (($ $ktrunc ($ $arity () () #f () #f) kseq)
+ ,(drop-result kseq))
+ (($ $kargs () () _)
+ ,(drop-result k))
+ (_
+ ($continue k ,exp)))))))
+
+ (define (visit-exp k exp)
+ (rewrite-cps-term exp
+ ((or ($ $void)
+ ($ $const)
+ ($ $prim)
+ ($ $var))
+ ,(adapt-exp 1 k exp))
+ (($ $fun)
+ ,(adapt-exp 1 k (fix-arities exp)))
+ (($ $call)
+ ;; In general, calls have unknown return arity. For that
+ ;; reason every non-tail call has an implicit adaptor
+ ;; continuation to adapt the return to the target
+ ;; continuation, and we don't need to do any adapting here.
+ ($continue k ,exp))
+ (($ $primcall 'return (arg))
+ ;; Primcalls to return are in tail position.
+ ($continue ktail ,exp))
+ (($ $primcall (? (lambda (name)
+ (and (not (prim-rtl-instruction name))
+ (not (branching-primitive? name))))))
+ ($continue k ,exp))
+ (($ $primcall name args)
+ ,(match (prim-arity name)
+ ((out . in)
+ (if (= in (length args))
+ (adapt-exp out k exp)
+ (let-gensyms (k* p*)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('prim) (p*)
+ ($continue k ($call p* args)))))
+ ($continue k* ($prim name)))))))))
+ (($ $values)
+ ;; Values nodes are inserted by CPS optimization passes, so
+ ;; we assume they are correct.
+ ($continue k ,exp))
+ (($ $prompt)
+ ($continue k ,exp))))
+
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kclause arity body))
+ (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+
+ (rewrite-cps-cont clause
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (sym src ($kentry self ,tail ,(map visit-cont clauses)))))))
+
+(define (fix-arities fun)
+ (rewrite-cps-exp fun
+ (($ $fun meta free body)
+ ($fun meta free ,(fix-clause-arities body)))))
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 7/9] Add pass to reify primcalls without corresponding VM ops
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (5 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 6/9] Add arity-adapting module Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 8/9] Add CPS -> RTL compiler Andy Wingo
` (3 subsequent siblings)
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am:
* module/language/cps/reify-primitives.scm: New pass.
---
module/Makefile.am | 1 +
module/language/cps/reify-primitives.scm | 117 +++++++++++++++++++++++++++++++
2 files changed, 118 insertions(+)
create mode 100644 module/language/cps/reify-primitives.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index bcef4bf..d7e524b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -123,6 +123,7 @@ CPS_LANG_SOURCES = \
language/cps/arities.scm \
language/cps/closure-conversion.scm \
language/cps/primitives.scm \
+ language/cps/reify-primitives.scm \
language/cps/spec.scm \
language/cps/verify.scm
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
new file mode 100644
index 0000000..ebd2da0
--- /dev/null
+++ b/module/language/cps/reify-primitives.scm
@@ -0,0 +1,117 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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 reify lone $prim's that were never folded into a
+;;; $primcall, and $primcall's to primitives that don't have a
+;;; corresponding VM op.
+;;;
+;;; Code:
+
+(define-module (language cps reify-primitives)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language rtl)
+ #:export (reify-primitives))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (build-cps-term
+ ($letconst (('module module-sym module)
+ ('name name-sym name)
+ ('public? public?-sym public?)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox
+ ($primcall 'cached-module-box
+ (module-sym name-sym public?-sym bound?-sym))))))))
+
+(define (primitive-ref name k)
+ (module-box #f '(guile) name #f #t
+ (lambda (box)
+ (build-cps-term
+ ($continue k ($primcall 'box-ref (box)))))))
+
+(define (reify-clause ktail)
+ (let-gensyms (kclause kbody wna false str eol kthrow throw)
+ (build-cps-cont
+ (kclause #f ($kclause ('() '() #f '() #f)
+ (kbody
+ #f
+ ($kargs () ()
+ ($letconst (('wna wna 'wrong-number-of-args)
+ ('false false #f)
+ ('str str "Wrong number of arguments")
+ ('eol eol '()))
+ ($letk ((kthrow
+ #f
+ ($kargs ('throw) (throw)
+ ($continue ktail
+ ($call throw
+ (wna false str eol false))))))
+ ,(primitive-ref 'throw kthrow))))))))))
+
+;; FIXME: Operate on one function at a time, for efficiency.
+(define (reify-primitives fun)
+ (let ((conts (build-cont-table fun)))
+ (define (visit-fun term)
+ (rewrite-cps-exp term
+ (($ $fun meta free body)
+ ($fun meta free ,(visit-cont body)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body))))
+ (($ $cont sym src ($ $kentry self (and tail ($ $cont ktail)) ()))
+ ;; A case-lambda with no clauses. Reify a clause.
+ (sym src ($kentry self ,tail (,(reify-clause ktail)))))
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (sym src ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym src ($ $kclause arity body))
+ (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $continue k exp)
+ ,(match exp
+ (($ $prim name)
+ (match (lookup-cont k conts)
+ (($ $kargs (_)) (primitive-ref name k))
+ (_ (build-cps-term ($continue k ($void))))))
+ (($ $fun)
+ (build-cps-term ($continue k ,(visit-fun exp))))
+ (($ $primcall name args)
+ (cond
+ ((or (prim-rtl-instruction name) (branching-primitive? name))
+ ;; Assume arities are correct.
+ term)
+ (else
+ (let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k ($call v args)))))
+ ,(primitive-ref name k*)))))))
+ (_ term)))))
+
+ (visit-fun fun)))
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 8/9] Add CPS -> RTL compiler
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (6 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 7/9] Add pass to reify primcalls without corresponding VM ops Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 9/9] Add contification pass Andy Wingo
` (2 subsequent siblings)
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/slot-allocation.scm: New modules.
* module/language/cps/spec.scm: Register the compiler.
* test-suite/Makefile.am:
* test-suite/tests/rtl-compilation.test: Add tests.
---
module/Makefile.am | 3 +
module/language/cps/compile-rtl.scm | 371 +++++++++++++++++++++++++++
module/language/cps/dfg.scm | 432 ++++++++++++++++++++++++++++++++
module/language/cps/slot-allocation.scm | 419 +++++++++++++++++++++++++++++++
module/language/cps/spec.scm | 3 +-
test-suite/Makefile.am | 1 +
test-suite/tests/rtl-compilation.test | 200 +++++++++++++++
7 files changed, 1428 insertions(+), 1 deletion(-)
create mode 100644 module/language/cps/compile-rtl.scm
create mode 100644 module/language/cps/dfg.scm
create mode 100644 module/language/cps/slot-allocation.scm
create mode 100644 test-suite/tests/rtl-compilation.test
diff --git a/module/Makefile.am b/module/Makefile.am
index d7e524b..5a0ff69 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -122,8 +122,11 @@ CPS_LANG_SOURCES = \
language/cps.scm \
language/cps/arities.scm \
language/cps/closure-conversion.scm \
+ language/cps/compile-rtl.scm \
+ language/cps/dfg.scm \
language/cps/primitives.scm \
language/cps/reify-primitives.scm \
+ language/cps/slot-allocation.scm \
language/cps/spec.scm \
language/cps/verify.scm
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
new file mode 100644
index 0000000..9277adf
--- /dev/null
+++ b/module/language/cps/compile-rtl.scm
@@ -0,0 +1,371 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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 CPS to RTL. The result is in the RTL language, which
+;;; happens to be an ELF image as a bytecode.
+;;;
+;;; Code:
+
+(define-module (language cps compile-rtl)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps arities)
+ #:use-module (language cps closure-conversion)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language cps reify-primitives)
+ #:use-module (language cps slot-allocation)
+ #:use-module (system vm assembler)
+ #:export (compile-rtl))
+
+;; TODO: Source info, local var names. Needs work in the linker and the
+;; debugger.
+
+(define (kw-arg-ref args kw default)
+ (match (memq kw args)
+ ((_ val . _) val)
+ (_ default)))
+
+(define (optimize exp opts)
+ (define (run-pass exp pass kw default)
+ (if (kw-arg-ref opts kw default)
+ (pass exp)
+ exp))
+
+ ;; Calls to source-to-source optimization passes go here.
+ (let* ()
+ ;; Passes that are needed:
+ ;;
+ ;; * Contification: turning $letrec-bound $funs into $letk-bound $conts.
+ ;;
+ ;; * Abort contification: turning abort primcalls into continuation
+ ;; calls, and eliding prompts if possible.
+ ;;
+ ;; * Common subexpression elimination. Desperately needed. Requires
+ ;; effects analysis.
+ ;;
+ ;; * Loop peeling. Unrolls the first round through a loop if the
+ ;; loop has effects that CSE can work on. Requires effects
+ ;; analysis. When run before CSE, loop peeling is the equivalent
+ ;; of loop-invariant code motion (LICM).
+ ;;
+ ;; * Generic simplification pass, to be run as needed. Used to
+ ;; "clean up", both on the original raw input and after specific
+ ;; optimization passes.
+
+ exp))
+
+(define (visit-funs proc exp)
+ (match exp
+ (($ $continue _ exp)
+ (visit-funs proc exp))
+
+ (($ $fun meta free body)
+ (proc exp)
+ (visit-funs proc body))
+
+ (($ $letk conts body)
+ (visit-funs proc body)
+ (for-each (lambda (cont) (visit-funs proc cont)) conts))
+
+ (($ $cont sym src ($ $kargs names syms body))
+ (visit-funs proc body))
+
+ (($ $cont sym src ($ $kclause arity body))
+ (visit-funs proc body))
+
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (for-each (lambda (clause) (visit-funs proc clause)) clauses))
+
+ (_ (values))))
+
+(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
+ (define (slot sym)
+ (lookup-slot sym allocation))
+
+ (define (constant sym)
+ (lookup-constant-value sym allocation))
+
+ (define (emit-rtl label k exp next-label)
+ (define (maybe-mov dst src)
+ (unless (= dst src)
+ (emit-mov asm dst src)))
+
+ (define (maybe-jump label)
+ (unless (eq? label next-label)
+ (emit-br asm label)))
+
+ (define (maybe-load-constant slot src)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value src allocation))
+ (lambda (has-const? val)
+ (and has-const?
+ (begin
+ (emit-load-constant asm slot val)
+ #t)))))
+
+ (define (emit-tail)
+ ;; There are only three kinds of expressions in tail position:
+ ;; tail calls, multiple-value returns, and single-value returns.
+ (match exp
+ (($ $call proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call asm (1+ (length args))))
+ (($ $values args)
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-reset-frame asm (1+ (length args)))
+ (emit-return-values asm))
+ (($ $primcall 'return (arg))
+ (emit-return asm (slot arg)))))
+
+ (define (emit-val sym)
+ (let ((dst (slot sym)))
+ (match exp
+ (($ $var sym)
+ (maybe-mov dst (slot sym)))
+ (($ $void)
+ (when dst
+ (emit-load-constant asm dst *unspecified*)))
+ (($ $const exp)
+ (when dst
+ (emit-load-constant asm dst exp)))
+ (($ $fun meta () ($ $cont k))
+ (emit-load-static-procedure asm dst k))
+ (($ $fun meta free ($ $cont k))
+ (emit-make-closure asm dst k (length free)))
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive asm dst proc-slot nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args))))))
+ (($ $primcall 'current-module)
+ (emit-current-module asm dst))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (constant bound?)))
+ (($ $primcall 'cached-module-box (mod name public? bound?))
+ (emit-cached-module-box asm dst (constant mod) (constant name)
+ (constant public?) (constant bound?)))
+ (($ $primcall 'resolve (name bound?))
+ (emit-resolve asm dst (constant bound?) (slot name)))
+ (($ $primcall 'free-ref (closure idx))
+ (emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall name args)
+ ;; FIXME: Inline all the cases.
+ (let ((inst (prim-rtl-instruction name)))
+ (emit-text asm `((,inst ,dst ,@(map slot args))))))
+ (($ $values (arg))
+ (or (maybe-load-constant dst arg)
+ (maybe-mov dst (slot arg))))
+ (($ $prompt escape? tag handler)
+ (emit-prompt asm escape? tag handler)))
+ (maybe-jump k)))
+
+ (define (emit-vals syms)
+ (match exp
+ (($ $primcall name args)
+ (error "unimplemented primcall in values context" name))
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant (map slot syms) args)))
+ (maybe-jump k))
+
+ (define (emit-seq)
+ (match exp
+ (($ $primcall 'cache-current-module! (sym scope))
+ (emit-cache-current-module! asm (slot sym) (constant scope)))
+ (($ $primcall 'free-set! (closure idx value))
+ (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+ (($ $primcall 'box-set! (box value))
+ (emit-box-set! asm (slot box) (slot value)))
+ (($ $primcall 'struct-set! (struct index value))
+ (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (($ $primcall 'vector-set! (vector index value))
+ (emit-vector-set asm (slot vector) (slot index) (slot value)))
+ (($ $primcall 'set-car! (pair value))
+ (emit-set-car! asm (slot pair) (slot value)))
+ (($ $primcall 'set-cdr! (pair value))
+ (emit-set-cdr! asm (slot pair) (slot value)))
+ (($ $primcall 'define! (sym value))
+ (emit-define asm (slot sym) (slot value)))
+ (($ $primcall name args)
+ (error "unhandled primcall in seq context" name))
+ (($ $values ()) #f))
+ (maybe-jump k))
+
+ (define (emit-test kt kf)
+ (define (unary op sym)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot sym) #t kf))
+ (else
+ (op asm (slot sym) #f kt)
+ (maybe-jump kf))))
+ (define (binary op a b)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot a) (slot b) #t kf))
+ (else
+ (op asm (slot a) (slot b) #f kt)
+ (maybe-jump kf))))
+ (match exp
+ (($ $var sym) (unary emit-br-if-true sym))
+ (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+ (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+ (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+ (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+ (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+ ;; Add TC7 tests here
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+ (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+ (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+ (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+ (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+ (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+ (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+
+ (define (emit-trunc nreq rest? k)
+ (match exp
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive-values asm proc-slot nreq)
+ (when rest?
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (emit-reset-frame asm nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args)))))))
+ (maybe-jump k))
+
+ (match (lookup-cont k cont-table)
+ (($ $ktail) (emit-tail))
+ (($ $kargs (name) (sym)) (emit-val sym))
+ (($ $kargs () ()) (emit-seq))
+ (($ $kargs names syms) (emit-vals syms))
+ (($ $kargs (name) (sym)) (emit-val sym))
+ (($ $kif kt kf) (emit-test kt kf))
+ (($ $ktrunc ($ $arity req () rest () #f) k)
+ (emit-trunc (length req) (and rest #t) k))))
+
+ (define (collect-exps k src cont tail)
+ (define (find-exp k src term)
+ (match term
+ (($ $continue exp-k exp)
+ (cons (list k src exp-k exp) tail))
+ (($ $letk conts body)
+ (find-exp k src body))))
+ (match cont
+ (($ $kargs names syms body)
+ (find-exp k src body))
+ (_ tail)))
+
+ (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
+ (match exps
+ (() #t)
+ (((k src exp-k exp) . exps)
+ (let ((next-label (match exps
+ (((k . _) . _) k)
+ (() #f))))
+ (emit-label asm k)
+ (emit-rtl k exp-k exp next-label)
+ (lp exps))))))
+
+(define (compile-fun f asm)
+ (let ((allocation (allocate-slots f))
+ (cont-table (match f
+ (($ $fun meta free body)
+ (build-local-cont-table body)))))
+ (define (emit-fun-clause clause alternate)
+ (match clause
+ (($ $cont k src
+ ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+ body))
+ (let ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (nlocals (lookup-nlocals k allocation)))
+ (emit-label asm k)
+ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+ nlocals alternate)
+ (emit-rtl-sequence asm body allocation nlocals cont-table)
+ (emit-end-arity asm)))))
+
+ (define (emit-fun-clauses clauses)
+ (match clauses
+ ((clause . clauses)
+ (let ((kalternate (match clauses
+ (() #f)
+ ((($ $cont k) . _) k))))
+ (emit-fun-clause clause kalternate)
+ (when kalternate
+ (emit-fun-clauses clauses))))))
+
+ (match f
+ (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
+ (emit-begin-program asm k (or meta '()))
+ (emit-fun-clauses clauses)
+ (emit-end-program asm)))))
+
+(define (compile-rtl exp env opts)
+ (let* ((exp (fix-arities exp))
+ (exp (optimize exp opts))
+ (exp (convert-closures exp))
+ (exp (reify-primitives exp))
+ (asm (make-assembler)))
+ (visit-funs (lambda (fun)
+ (compile-fun fun asm))
+ exp)
+ (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
+ env
+ env)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
new file mode 100644
index 0000000..0826451
--- /dev/null
+++ b/module/language/cps/dfg.scm
@@ -0,0 +1,432 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;; Many passes rely on a local or global static analysis of a function.
+;;; This module implements a simple data-flow graph (DFG) analysis,
+;;; tracking the definitions and uses of variables and continuations.
+;;; It also builds a table of continuations and parent links, to be able
+;;; to easily determine if one continuation is in the scope of another,
+;;; and to get to the expression inside a continuation.
+;;;
+;;; Note that the data-flow graph of continuation labels is a
+;;; control-flow graph.
+;;;
+;;; We currently don't expose details of the DFG type outside this
+;;; module, preferring to only expose accessors. That may change in the
+;;; future but it seems to work for now.
+;;;
+;;; Code:
+
+(define-module (language cps dfg)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (build-cont-table
+ build-local-cont-table
+ lookup-cont
+
+ compute-dfg
+ dfg-cont-table
+ lookup-def
+ lookup-uses
+ find-call
+ call-expression
+ find-expression
+ find-defining-expression
+ find-constant-value
+ lift-definition!
+ variable-used-in?
+ constant-needs-allocation?
+ dead-after-def?
+ dead-after-use?
+ branch?
+ find-other-branches
+ dead-after-branch?
+ lookup-bound-syms))
+
+(define (build-cont-table fun)
+ (fold-conts (lambda (k src cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ fun))
+
+(define (build-local-cont-table cont)
+ (fold-local-conts (lambda (k src cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ cont))
+
+(define (lookup-cont sym conts)
+ (let ((res (hashq-ref conts sym)))
+ (unless res
+ (error "Unknown continuation!" sym (hash-fold acons '() conts)))
+ res))
+
+;; Data-flow graph for CPS: both for values and continuations.
+(define-record-type $dfg
+ (make-dfg conts use-maps uplinks)
+ dfg?
+ ;; hash table of sym -> $kargs, $kif, etc
+ (conts dfg-cont-table)
+ ;; hash table of sym -> $use-map
+ (use-maps dfg-use-maps)
+ ;; hash table of sym -> $parent-link
+ (uplinks dfg-uplinks))
+
+(define-record-type $use-map
+ (make-use-map sym def uses)
+ use-map?
+ (sym use-map-sym)
+ (def use-map-def)
+ (uses use-map-uses set-use-map-uses!))
+
+(define-record-type $uplink
+ (make-uplink parent level)
+ uplink?
+ (parent uplink-parent)
+ (level uplink-level))
+
+(define (visit-fun fun conts use-maps uplinks global?)
+ (define (add-def! sym def-k)
+ (unless def-k
+ (error "Term outside labelled continuation?"))
+ (hashq-set! use-maps sym (make-use-map sym def-k '())))
+
+ (define (add-use! sym use-k)
+ (match (hashq-ref use-maps sym)
+ (#f (error "Symbol out of scope?" sym))
+ ((and use-map ($ $use-map sym def uses))
+ (set-use-map-uses! use-map (cons use-k uses)))))
+
+ (define (link-parent! k parent)
+ (match (hashq-ref uplinks parent)
+ (($ $uplink _ level)
+ (hashq-set! uplinks k (make-uplink parent (1+ level))))))
+
+ (define (visit exp exp-k)
+ (define (def! sym)
+ (add-def! sym exp-k))
+ (define (use! sym)
+ (add-use! sym exp-k))
+ (define (recur exp)
+ (visit exp exp-k))
+ (match exp
+ (($ $letk (($ $cont k src cont) ...) body)
+ ;; Set up recursive environment before visiting cont bodies.
+ (for-each (lambda (cont k)
+ (def! k)
+ (hashq-set! conts k cont)
+ (link-parent! k exp-k))
+ cont k)
+ (for-each visit cont k)
+ (recur body))
+
+ (($ $kargs names syms body)
+ (for-each def! syms)
+ (recur body))
+
+ (($ $kif kt kf)
+ (use! kt)
+ (use! kf))
+
+ (($ $ktrunc arity k)
+ (use! k))
+
+ (($ $letrec names syms funs body)
+ (unless global?
+ (error "$letrec should not be present when building a local DFG"))
+ (for-each def! syms)
+ (for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
+ (visit body exp-k))
+
+ (($ $continue k exp)
+ (use! k)
+ (match exp
+ (($ $var sym)
+ (use! sym))
+
+ (($ $call proc args)
+ (use! proc)
+ (for-each use! args))
+
+ (($ $primcall name args)
+ (for-each use! args))
+
+ (($ $values args)
+ (for-each use! args))
+
+ (($ $prompt escape? tag handler)
+ (use! tag)
+ (use! handler))
+
+ (($ $fun)
+ (when global?
+ (visit-fun exp conts use-maps uplinks global?)))
+
+ (_ #f)))))
+
+ (match fun
+ (($ $fun meta free
+ ($ $cont kentry src
+ (and entry
+ ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ ;; Treat the fun continuation as its own parent.
+ (add-def! kentry kentry)
+ (add-def! self kentry)
+ (hashq-set! uplinks kentry (make-uplink #f 0))
+ (hashq-set! conts kentry entry)
+
+ (add-def! ktail kentry)
+ (hashq-set! conts ktail tail)
+ (link-parent! ktail kentry)
+
+ (for-each
+ (match-lambda
+ (($ $cont kclause _
+ (and clause ($ $kclause arity ($ $cont kbody _ body))))
+ (add-def! kclause kentry)
+ (hashq-set! conts kclause clause)
+ (link-parent! kclause kentry)
+
+ (add-def! kbody kclause)
+ (hashq-set! conts kbody body)
+ (link-parent! kbody kclause)
+
+ (visit body kbody)))
+ clauses))))
+
+(define* (compute-dfg fun #:key (global? #t))
+ (let* ((conts (make-hash-table))
+ (use-maps (make-hash-table))
+ (uplinks (make-hash-table)))
+ (visit-fun fun conts use-maps uplinks global?)
+ (make-dfg conts use-maps uplinks)))
+
+(define (lookup-uplink k uplinks)
+ (let ((res (hashq-ref uplinks k)))
+ (unless res
+ (error "Unknown continuation!" k (hash-fold acons '() uplinks)))
+ res))
+
+(define (lookup-use-map sym use-maps)
+ (let ((res (hashq-ref use-maps sym)))
+ (unless res
+ (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
+ res))
+
+(define (lookup-def sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ def)))))
+
+(define (lookup-uses sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ uses)))))
+
+(define (find-defining-term sym dfg)
+ (match (lookup-uses (lookup-def sym dfg) dfg)
+ ((def-exp-k)
+ (lookup-cont def-exp-k (dfg-cont-table dfg)))
+ (else #f)))
+
+(define (find-call term)
+ (match term
+ (($ $kargs names syms body) (find-call body))
+ (($ $letk conts body) (find-call body))
+ (($ $letrec names syms funs body) (find-call body))
+ (($ $continue) term)))
+
+(define (call-expression call)
+ (match call
+ (($ $continue k exp) exp)))
+
+(define (find-expression term)
+ (call-expression (find-call term)))
+
+(define (find-defining-expression sym dfg)
+ (match (find-defining-term sym dfg)
+ (#f #f)
+ (($ $ktrunc) #f)
+ (term (find-expression term))))
+
+(define (find-constant-value sym dfg)
+ (match (find-defining-expression sym dfg)
+ (($ $const val)
+ (values #t val))
+ (($ $continue k ($ $void))
+ (values #t *unspecified*))
+ (else
+ (values #f #f))))
+
+(define (constant-needs-allocation? sym val dfg)
+ (define (find-exp term)
+ (match term
+ (($ $kargs names syms body) (find-exp body))
+ (($ $letk conts body) (find-exp body))
+ (else term)))
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map _ def uses)
+ (or-map
+ (lambda (use)
+ (match (find-expression (lookup-cont use conts))
+ (($ $call) #f)
+ (($ $values) #f)
+ (($ $primcall 'free-ref (closure slot))
+ (not (eq? sym slot)))
+ (($ $primcall 'free-set! (closure slot value))
+ (not (eq? sym slot)))
+ (($ $primcall 'cache-current-module! (mod . _))
+ (eq? sym mod))
+ (($ $primcall 'cached-toplevel-box _)
+ #f)
+ (($ $primcall 'cached-module-box _)
+ #f)
+ (($ $primcall 'resolve (name bound?))
+ (eq? sym name))
+ (_ #t)))
+ uses))))))
+
+(define (continuation-scope-contains? parent-k k uplinks)
+ (match (lookup-uplink parent-k uplinks)
+ (($ $uplink _ parent-level)
+ (let lp ((k k))
+ (or (eq? parent-k k)
+ (match (lookup-uplink k uplinks)
+ (($ $uplink parent level)
+ (and (< parent-level level)
+ (lp parent)))))))))
+
+(define (lift-definition! k parent-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-uplink parent-k uplinks)
+ (($ $uplink parent level)
+ (hashq-set! uplinks k
+ (make-uplink parent-k (1+ level)))
+ ;; Lift definitions of all conts in K.
+ (let lp ((cont (lookup-cont k conts)))
+ (match cont
+ (($ $letk (($ $cont kid) ...) body)
+ (for-each (cut lift-definition! <> k dfg) kid)
+ (lp body))
+ (($ $letrec names syms funs body)
+ (lp body))
+ (_ #t))))))))
+
+(define (variable-used-in? var parent-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (or-map (lambda (use)
+ (continuation-scope-contains? parent-k use uplinks))
+ (match (lookup-use-map var use-maps)
+ (($ $use-map sym def uses)
+ uses))))))
+
+;; Does k1 dominate k2?
+;;
+;; Note that this is a conservative predicate: a false return value does
+;; not indicate that k1 _doesn't_ dominate k2. The reason for this is
+;; that we are using the scope tree as an approximation of the dominator
+;; relationship. See
+;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
+;; deeper discussion.
+(define (conservatively-dominates? k1 k2 uplinks)
+ (continuation-scope-contains? k1 k2 uplinks))
+
+(define (dead-after-def? sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ (null? uses))))))
+
+(define (dead-after-use? sym use-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ ;; If all other uses dominate this use, it is now dead. There
+ ;; are other ways for it to be dead, but this is an
+ ;; approximation. A better check would be if the successor
+ ;; post-dominates all uses.
+ (and-map (cut conservatively-dominates? <> use-k uplinks)
+ uses))))))
+
+;; A continuation is a "branch" if all of its predecessors are $kif
+;; continuations.
+(define (branch? k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map k use-maps)
+ (($ $use-map sym def uses)
+ (and (not (null? uses))
+ (and-map (lambda (k)
+ (match (lookup-cont k conts)
+ (($ $kif) #t)
+ (_ #f)))
+ uses)))))))
+
+(define (find-other-branches k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map k use-maps)
+ (($ $use-map sym def (uses ..1))
+ (map (lambda (kif)
+ (match (lookup-cont kif conts)
+ (($ $kif (? (cut eq? <> k)) kf)
+ kf)
+ (($ $kif kt (? (cut eq? <> k)))
+ kt)
+ (_ (error "Not all predecessors are branches"))))
+ uses))))))
+
+(define (dead-after-branch? sym branch other-branches dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ (and-map
+ (lambda (use-k)
+ ;; A symbol is dead after a branch if at least one of the
+ ;; other branches dominates a use of the symbol, and all
+ ;; other uses of the symbol dominate the test.
+ (if (or-map (cut conservatively-dominates? <> use-k uplinks)
+ other-branches)
+ (not (conservatively-dominates? branch use-k uplinks))
+ (conservatively-dominates? use-k branch uplinks)))
+ uses))))))
+
+(define (lookup-bound-syms k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-cont k conts)
+ (($ $kargs names syms body)
+ syms)))))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
new file mode 100644
index 0000000..a7b9f74
--- /dev/null
+++ b/module/language/cps/slot-allocation.scm
@@ -0,0 +1,419 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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 module to assign stack slots to variables in a CPS term.
+;;;
+;;; Code:
+
+(define-module (language cps slot-allocation)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (allocate-slots
+ lookup-slot
+ lookup-constant-value
+ lookup-maybe-constant-value
+ lookup-nlocals
+ lookup-call-proc-slot
+ lookup-parallel-moves))
+
+;; Continuations can bind variables. The $allocation structure
+;; represents the slot in which a variable is stored.
+;;
+;; Not all variables have slots allocated. Variables that are constant
+;; and that are only used by primcalls that can accept constants
+;; directly are not allocated to slots, and their SLOT value is false.
+;; Likewise constants that are only used by calls are not allocated into
+;; slots, to avoid needless copying. If a variable is constant, its
+;; constant value is set to the CONST slot and HAS-CONST? is set to a
+;; true value.
+;;
+;; DEF holds the label of the continuation that defines the variable,
+;; and DEAD is a list of continuations at which the variable becomes
+;; dead.
+(define-record-type $allocation
+ (make-allocation def slot dead has-const? const)
+ allocation?
+ (def allocation-def)
+ (slot allocation-slot)
+ (dead allocation-dead set-allocation-dead!)
+ (has-const? allocation-has-const?)
+ (const allocation-const))
+
+;; Continuations can also have associated allocation data. For example,
+;; when a call happens in a labelled continuation, we need to know what
+;; slot the procedure goes in. Likewise before branching to the target
+;; continuation, we might need to shuffle values into the right place: a
+;; parallel move. $cont-allocation stores allocation data keyed on the
+;; continuation label.
+(define-record-type $cont-allocation
+ (make-cont-allocation call-proc-slot parallel-moves)
+ cont-allocation?
+
+ ;; Currently calls are allocated in the caller frame, above all locals
+ ;; that are live at the time of the call. Therefore there is no
+ ;; parallel move problem. We could be more clever here.
+ (call-proc-slot cont-call-proc-slot)
+
+ ;; Tail calls, multiple-value returns, and jumps to continuations with
+ ;; multiple arguments are forms of parallel assignment. A
+ ;; $parallel-move represents a specific solution to the parallel
+ ;; assignment problem, with an ordered list of (SRC . DST) moves. This
+ ;; may involve a temporary variable.
+ ;;
+ ;; ((src . dst) ...)
+ (parallel-moves cont-parallel-moves))
+
+(define (find-first-zero n)
+ ;; Naive implementation.
+ (let lp ((slot 0))
+ (if (logbit? slot n)
+ (lp (1+ slot))
+ slot)))
+
+(define (find-first-trailing-zero n count)
+ (let lp ((slot count))
+ (if (or (zero? slot) (logbit? (1- slot) n))
+ slot
+ (lp (1- slot)))))
+
+(define (lookup-allocation sym allocation)
+ (let ((res (hashq-ref allocation sym)))
+ (unless res
+ (error "Variable or continuation not defined" sym))
+ res))
+
+(define (lookup-slot sym allocation)
+ (match (lookup-allocation sym allocation)
+ (($ $allocation def slot dead has-const? const) slot)))
+
+(define (lookup-constant-value sym allocation)
+ (match (lookup-allocation sym allocation)
+ (($ $allocation def slot dead #t const) const)
+ (_
+ (error "Variable does not have constant value" sym))))
+
+(define (lookup-maybe-constant-value sym allocation)
+ (match (lookup-allocation sym allocation)
+ (($ $allocation def slot dead has-const? const)
+ (values has-const? const))))
+
+(define (lookup-call-proc-slot k allocation)
+ (match (lookup-allocation k allocation)
+ (($ $cont-allocation proc-slot parallel-moves)
+ (unless proc-slot
+ (error "Continuation not a call" k))
+ proc-slot)
+ (_
+ (error "Continuation not a call" k))))
+
+(define (lookup-nlocals k allocation)
+ (match (lookup-allocation k allocation)
+ ((? number? nlocals) nlocals)
+ (_
+ (error "Not a clause continuation" k))))
+
+(define (lookup-parallel-moves k allocation)
+ (match (lookup-allocation k allocation)
+ (($ $cont-allocation proc-slot parallel-moves)
+ (unless parallel-moves
+ (error "Continuation does not have parallel moves" k))
+ parallel-moves)
+ (_
+ (error "Continuation not a call" k))))
+
+(define (solve-parallel-move src dst tmp)
+ "Solve the parallel move problem between src and dst slot lists, which
+are comparable with eqv?. A tmp slot may be used."
+
+ ;; This algorithm is taken from: "Tilting at windmills with Coq:
+ ;; formal verification of a compilation algorithm for parallel moves"
+ ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
+ ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
+
+ (define (split-move moves reg)
+ (let loop ((revhead '()) (tail moves))
+ (match tail
+ (((and s+d (s . d)) . rest)
+ (if (eqv? s reg)
+ (cons d (append-reverse revhead rest))
+ (loop (cons s+d revhead) rest)))
+ (_ #f))))
+
+ (define (replace-last-source reg moves)
+ (match moves
+ ((moves ... (s . d))
+ (append moves (list (cons reg d))))))
+
+ (let loop ((to-move (map cons src dst))
+ (being-moved '())
+ (moved '())
+ (last-source #f))
+ ;; 'last-source' should always be equivalent to:
+ ;; (and (pair? being-moved) (car (last being-moved)))
+ (match being-moved
+ (() (match to-move
+ (() (reverse moved))
+ (((and s+d (s . d)) . t1)
+ (if (or (eqv? s d) ; idempotent
+ (not s)) ; src is a constant and can be loaded directly
+ (loop t1 '() moved #f)
+ (loop t1 (list s+d) moved s)))))
+ (((and s+d (s . d)) . b)
+ (match (split-move to-move d)
+ ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
+ (#f (match b
+ (() (loop to-move '() (cons s+d moved) #f))
+ (_ (if (eqv? d last-source)
+ (loop to-move
+ (replace-last-source tmp b)
+ (cons s+d (acons d tmp moved))
+ tmp)
+ (loop to-move b (cons s+d moved) last-source))))))))))
+
+(define (allocate-slots fun)
+ (define (empty-live-set)
+ (cons #b0 '()))
+
+ (define (add-live-variable sym slot live-set)
+ (cons (logior (car live-set) (ash 1 slot))
+ (acons sym slot (cdr live-set))))
+
+ (define (remove-live-variable sym slot live-set)
+ (cons (logand (car live-set) (lognot (ash 1 slot)))
+ (acons sym #f (cdr live-set))))
+
+ (define (fold-live-set proc seed live-set)
+ (let lp ((bits (car live-set)) (clauses (cdr live-set)) (seed seed))
+ (if (zero? bits)
+ seed
+ (match clauses
+ (((sym . slot) . clauses)
+ (if (and slot (logbit? slot bits))
+ (lp (logand bits (lognot (ash 1 slot)))
+ clauses
+ (proc sym slot seed))
+ (lp bits clauses seed)))))))
+
+ (define (compute-slot live-set hint)
+ (if (and hint (not (logbit? hint (car live-set))))
+ hint
+ (find-first-zero (car live-set))))
+
+ (define (compute-call-proc-slot live-set nlocals)
+ (+ 3 (find-first-trailing-zero (car live-set) nlocals)))
+
+ (define dfg (compute-dfg fun #:global? #f))
+ (define allocation (make-hash-table))
+
+ (define (visit-clause clause live-set)
+ (define nlocals (compute-slot live-set #f))
+ (define nargs
+ (match clause
+ (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
+ (length syms))))
+
+ (define (allocate! sym k hint live-set)
+ (match (hashq-ref allocation sym)
+ (($ $allocation def slot dead has-const)
+ ;; Parallel move already allocated this one.
+ (if slot
+ (add-live-variable sym slot live-set)
+ live-set))
+ (_
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? const)
+ (cond
+ ((and has-const? (not (constant-needs-allocation? sym const dfg)))
+ (hashq-set! allocation sym
+ (make-allocation k #f '() has-const? const))
+ live-set)
+ (else
+ (let ((slot (compute-slot live-set hint)))
+ (when (>= slot nlocals)
+ (set! nlocals (+ slot 1)))
+ (hashq-set! allocation sym
+ (make-allocation k slot '() has-const? const))
+ (add-live-variable sym slot live-set)))))))))
+
+ (define (dead sym k live-set)
+ (match (lookup-allocation sym allocation)
+ ((and allocation ($ $allocation def slot dead has-const? const))
+ (set-allocation-dead! allocation (cons k dead))
+ (remove-live-variable sym slot live-set))))
+
+ (define (allocate-frame! k nargs live-set)
+ (let ((proc-slot (compute-call-proc-slot live-set nlocals)))
+ (set! nlocals (max nlocals (+ proc-slot 1 nargs)))
+ (hashq-set! allocation k
+ (make-cont-allocation
+ proc-slot
+ (match (hashq-ref allocation k)
+ (($ $cont-allocation #f moves) moves)
+ (#f #f))))
+ live-set))
+
+ (define (parallel-move! src-k src-slots pre-live-set post-live-set dst-slots)
+ (let* ((tmp-slot (find-first-zero (logior (car pre-live-set)
+ (car post-live-set))))
+ (moves (solve-parallel-move src-slots dst-slots tmp-slot)))
+ (when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
+ (set! nlocals (+ tmp-slot 1)))
+ (hashq-set! allocation src-k
+ (make-cont-allocation
+ (match (hashq-ref allocation src-k)
+ (($ $cont-allocation proc-slot #f) proc-slot)
+ (#f #f))
+ moves))
+ post-live-set))
+
+ (define (visit-cont cont label live-set)
+ (define (maybe-kill-definition sym live-set)
+ (if (and (lookup-slot sym allocation) (dead-after-def? sym dfg))
+ (dead sym label live-set)
+ live-set))
+
+ (define (kill-conditionally-dead live-set)
+ (if (branch? label dfg)
+ (let ((branches (find-other-branches label dfg)))
+ (fold-live-set
+ (lambda (sym slot live-set)
+ (if (and (> slot nargs)
+ (dead-after-branch? sym label branches dfg))
+ (dead sym label live-set)
+ live-set))
+ live-set
+ live-set))
+ live-set))
+
+ (match cont
+ (($ $kentry self tail clauses)
+ (let ((live-set (allocate! self label 0 live-set)))
+ (for-each (cut visit-cont <> label live-set) clauses))
+ live-set)
+
+ (($ $kclause arity ($ $cont k src body))
+ (visit-cont body k live-set))
+
+ (($ $kargs names syms body)
+ (visit-term body label
+ (kill-conditionally-dead
+ (fold maybe-kill-definition
+ (fold (cut allocate! <> label #f <>) live-set syms)
+ syms))))
+
+ (($ $ktrunc) live-set)
+ (($ $kif) live-set)))
+
+ (define (visit-term term label live-set)
+ (match term
+ (($ $letk conts body)
+ (let ((live-set (visit-term body label live-set)))
+ (for-each (match-lambda
+ (($ $cont k src cont)
+ (visit-cont cont k live-set)))
+ conts))
+ live-set)
+
+ (($ $continue k exp)
+ (visit-exp exp label k live-set))))
+
+ (define (visit-exp exp label k live-set)
+ (define (use sym live-set)
+ (if (and (lookup-slot sym allocation) (dead-after-use? sym k dfg))
+ (dead sym k live-set)
+ live-set))
+
+ (match exp
+ (($ $var sym)
+ (use sym live-set))
+
+ (($ $call proc args)
+ (match (lookup-cont k (dfg-cont-table dfg))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length args))))
+ (set! nlocals (max nlocals tail-nlocals))
+ (parallel-move! label
+ (map (cut lookup-slot <> allocation)
+ (cons proc args))
+ live-set (fold use live-set (cons proc args))
+ (iota tail-nlocals))))
+ (($ $ktrunc arity kargs)
+ (let* ((live-set
+ (fold use
+ (use proc
+ (allocate-frame! label (length args) live-set))
+ args))
+ (proc-slot (lookup-call-proc-slot label allocation))
+ (dst-syms (lookup-bound-syms kargs dfg))
+ (nvals (length dst-syms))
+ (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
+ (live-set* (fold (cut allocate! <> kargs <> <>)
+ live-set dst-syms src-slots))
+ (dst-slots (map (cut lookup-slot <> allocation)
+ dst-syms)))
+ (parallel-move! label src-slots live-set live-set* dst-slots)))
+ (else
+ (fold use
+ (use proc (allocate-frame! label (length args) live-set))
+ args))))
+
+ (($ $primcall name args)
+ (fold use live-set args))
+
+ (($ $values args)
+ (let ((live-set* (fold use live-set args)))
+ (define (compute-dst-slots)
+ (match (lookup-cont k (dfg-cont-table dfg))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length args))))
+ (set! nlocals (max nlocals tail-nlocals))
+ (cdr (iota tail-nlocals))))
+ (_
+ (let* ((src-slots (map (cut lookup-slot <> allocation) args))
+ (dst-syms (lookup-bound-syms k dfg))
+ (dst-live-set (fold (cut allocate! <> k <> <>)
+ live-set* dst-syms src-slots)))
+ (map (cut lookup-slot <> allocation) dst-syms)))))
+
+ (parallel-move! label
+ (map (cut lookup-slot <> allocation) args)
+ live-set live-set*
+ (compute-dst-slots))))
+
+ (($ $prompt escape? tag handler)
+ (use tag live-set))
+
+ (_ live-set)))
+
+ (match clause
+ (($ $cont k _ body)
+ (visit-cont body k live-set)
+ (hashq-set! allocation k nlocals))))
+
+ (match fun
+ (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
+ (let ((live-set (add-live-variable self 0 (empty-live-set))))
+ (hashq-set! allocation self (make-allocation k 0 '() #f #f))
+ (for-each (cut visit-clause <> live-set) clauses)
+ allocation))))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
index 38dc54d..493b547 100644
--- a/module/language/cps/spec.scm
+++ b/module/language/cps/spec.scm
@@ -21,6 +21,7 @@
(define-module (language cps spec)
#:use-module (system base language)
#:use-module (language cps)
+ #:use-module (language cps compile-rtl)
#:export (cps))
(define* (write-cps exp #:optional (port (current-output-port)))
@@ -31,6 +32,6 @@
#:reader (lambda (port env) (read port))
#:printer write-cps
#:parser parse-cps
- #:compilers '()
+ #:compilers `((rtl . ,compile-rtl))
#:for-humans? #f
)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index fad64b7..c4e4d1f 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,6 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/receive.test \
tests/regexp.test \
tests/rtl.test \
+ tests/rtl-compilation.test \
tests/session.test \
tests/signals.test \
tests/srcprop.test \
diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test
new file mode 100644
index 0000000..cf00a4f
--- /dev/null
+++ b/test-suite/tests/rtl-compilation.test
@@ -0,0 +1,200 @@
+;;;; rtl-compilation.test --- test suite for compiling via rtl -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2013 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
+
+(define-module (test-suite rtl-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system vm objcode))
+
+(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module)))
+ (load-thunk-from-memory
+ (compile exp #:env env #:to 'rtl
+ #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-rtl exp #:key (env (make-fresh-user-module)))
+ (let ((thunk (compile-via-rtl exp #:env env)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (thunk)))))
+
+(with-test-prefix "tail context"
+ (pass-if-equal 1
+ (run-rtl '(let ((x 1)) x)))
+
+ (pass-if-equal 1
+ (run-rtl 1))
+
+ (pass-if-equal (if #f #f)
+ (run-rtl '(if #f #f)))
+
+ (pass-if-equal "top-level define"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (let ((result (run-rtl '(define v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level set!"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'v #f)
+ (let ((result (run-rtl '(set! v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level apply [single value]"
+ 8
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'args '(2 3))
+ (run-rtl '(apply expt args) #:env mod)))
+
+ (pass-if-equal "top-level apply [zero values]"
+ '()
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda () (values)))
+ (module-define! mod 'args '())
+ (call-with-values
+ (lambda () (run-rtl '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "top-level apply [two values]"
+ '(1 2)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda (n d) (floor/ n d)))
+ (module-define! mod 'args '(5 3))
+ (call-with-values
+ (lambda () (run-rtl '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "call-with-values"
+ '(1 2 3)
+ ((run-rtl '(lambda (n d)
+ (call-with-values (lambda () (floor/ n d))
+ (lambda (q r) (list q r (+ q r))))))
+ 5 3))
+
+ (pass-if-equal cons
+ (run-rtl 'cons))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda () 1))))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda (x) 1)) 2))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda (x) x)) 1))
+
+ (pass-if-equal 6
+ ((((run-rtl '(lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))) 1) 2) 3))
+
+ (pass-if-equal 1
+ (run-rtl '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-rtl '(cons 1 2)))
+
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-rtl '(values 1 2))) list))
+
+ (pass-if-equal 28
+ ((run-rtl '(lambda (x y z rest) (apply + x y z rest)))
+ 2 3 5 '(7 11)))
+
+ ;; prompts
+ )
+
+(with-test-prefix "value context"
+ 1
+ )
+
+(with-test-prefix "drop context"
+ 1
+ )
+
+(with-test-prefix "test context"
+ 1
+ )
+
+(with-test-prefix "values context"
+ (pass-if-equal '(3 . 1)
+ (run-rtl
+ '(let ((rat (lambda (n d)
+ (call-with-values
+ (lambda () (floor/ n d))
+ (lambda (q r)
+ (cons q r))))))
+ (rat 10 3)))))
+
+(with-test-prefix "contification"
+ (pass-if ((run-rtl '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3 4)))
+
+ (pass-if (not ((run-rtl '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3)))))
+
+(with-test-prefix "case-lambda"
+ (pass-if-equal "simple"
+ '(0 3 9 28)
+ (let ((proc (run-rtl '(case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z . rest) (apply + x y z rest))))))
+ (map (lambda (args) (apply proc args))
+ '(() (3) (2 7) (2 3 5 7 11)))))
+
+ (pass-if-exception "no match"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y))))
+ 1 2 3))
+
+ (pass-if-exception "zero clauses called with no args"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda))))
+
+ (pass-if-exception "zero clauses called with args"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+ (pass-if-equal "sequences" '(3 4 5)
+ (let* ((pair (cons 1 2))
+ (result ((run-rtl '(lambda (pair)
+ (set-car! pair 3)
+ (set-cdr! pair 4)
+ 5))
+ pair)))
+ (list (car pair)
+ (cdr pair)
+ result)))
+
+ (pass-if-equal "mutable lexicals" 2
+ (run-rtl '(let ((n 1)) (set! n 2) n))))
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [PATCH 9/9] Add contification pass
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (7 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 8/9] Add CPS -> RTL compiler Andy Wingo
@ 2013-08-29 7:49 ` Andy Wingo
2013-08-29 20:42 ` CPS language and Tree-IL->CPS->RTL compiler Ludovic Courtès
2013-08-29 21:52 ` Noah Lavine
10 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-29 7:49 UTC (permalink / raw)
To: guile-devel; +Cc: Andy Wingo
* module/Makefile.am:
* module/language/cps/contification.scm: New pass.
* module/language/cps/compile-rtl.scm (optimize): Wire it into the
compiler.
---
module/Makefile.am | 1 +
module/language/cps/compile-rtl.scm | 5 +-
module/language/cps/contification.scm | 238 ++++++++++++++++++++++++++++++++++
3 files changed, 241 insertions(+), 3 deletions(-)
create mode 100644 module/language/cps/contification.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 5a0ff69..0e6fdf6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -123,6 +123,7 @@ CPS_LANG_SOURCES = \
language/cps/arities.scm \
language/cps/closure-conversion.scm \
language/cps/compile-rtl.scm \
+ language/cps/contification.scm \
language/cps/dfg.scm \
language/cps/primitives.scm \
language/cps/reify-primitives.scm \
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 9277adf..b126738 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -29,6 +29,7 @@
#:use-module (language cps)
#:use-module (language cps arities)
#:use-module (language cps closure-conversion)
+ #:use-module (language cps contification)
#:use-module (language cps dfg)
#:use-module (language cps primitives)
#:use-module (language cps reify-primitives)
@@ -51,11 +52,9 @@
exp))
;; Calls to source-to-source optimization passes go here.
- (let* ()
+ (let* ((exp (run-pass exp contify #:contify? #t)))
;; Passes that are needed:
;;
- ;; * Contification: turning $letrec-bound $funs into $letk-bound $conts.
- ;;
;; * Abort contification: turning abort primcalls into continuation
;; calls, and eliding prompts if possible.
;;
diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm
new file mode 100644
index 0000000..b1932dd
--- /dev/null
+++ b/module/language/cps/contification.scm
@@ -0,0 +1,238 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 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:
+;;;
+;;; Contification is a pass that turns $fun instances into $cont
+;;; instances if all calls to the $fun return to the same continuation.
+;;; This is a more rigorous variant of our old "fixpoint labels
+;;; allocation" optimization.
+;;;
+;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
+;;; and Weeks's "Contification using Dominators".
+;;;
+;;; Code:
+
+(define-module (language cps contification)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (concatenate))
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language rtl)
+ #:export (contify))
+
+(define (contify fun)
+ (let* ((dfg (compute-dfg fun))
+ (cont-table (dfg-cont-table dfg))
+ (call-substs '())
+ (cont-substs '()))
+ (define (subst-call! sym arities body-ks)
+ (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
+ (define (subst-return! old-tail new-tail)
+ (set! cont-substs (acons old-tail new-tail cont-substs)))
+ (define (lookup-return-cont k)
+ (or (assq-ref cont-substs k) k))
+
+ (define (contify-call proc args)
+ (and=> (assq-ref call-substs proc)
+ (lambda (clauses)
+ (let lp ((clauses clauses))
+ (match clauses
+ (() (error "invalid contification"))
+ (((($ $arity req () #f () #f) . k) . clauses)
+ (if (= (length req) (length args))
+ (build-cps-term
+ ($continue k ($values args)))
+ (lp clauses)))
+ ((_ . clauses) (lp clauses)))))))
+
+ ;; If K is a continuation that binds one variable, and it has only
+ ;; one predecessor, return that variable.
+ (define (bound-symbol k)
+ (match (lookup-cont k cont-table)
+ (($ $kargs (_) (sym))
+ (match (lookup-uses k dfg)
+ ((_)
+ ;; K has one predecessor, the one that defined SYM.
+ sym)
+ (_ #f)))
+ (_ #f)))
+
+ (define (contify-fun term-k sym self tail arities bodies)
+ (contify-funs term-k
+ (list sym) (list self) (list tail)
+ (list arities) (list bodies)))
+
+ (define (contify-funs term-k syms selfs tails arities bodies)
+ ;; Are the given args compatible with any of the arities?
+ (define (applicable? proc args)
+ (or-map (match-lambda
+ (($ $arity req () #f () #f)
+ (= (length args) (length req)))
+ (_ #f))
+ (assq-ref (map cons syms arities) proc)))
+
+ ;; If the use of PROC in continuation USE is a call to PROC that
+ ;; is compatible with one of the procedure's arities, return the
+ ;; target continuation. Otherwise return #f.
+ (define (call-target use proc)
+ (match (find-call (lookup-cont use cont-table))
+ (($ $continue k ($ $call proc* args))
+ (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
+ k))
+ (_ #f)))
+
+ (and
+ (and-map null? (map (cut lookup-uses <> dfg) selfs))
+ (and=> (let visit-syms ((syms syms) (k #f))
+ (match syms
+ (() k)
+ ((sym . syms)
+ (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
+ (match uses
+ (() (visit-syms syms k))
+ ((use . uses)
+ (and=> (call-target use sym)
+ (lambda (k*)
+ (cond
+ ((memq k* tails) (visit-uses uses k))
+ ((not k) (visit-uses uses k*))
+ ((eq? k k*) (visit-uses uses k))
+ (else #f))))))))))
+ (lambda (k)
+ ;; We have a common continuation, so we contify: mark
+ ;; all SYMs for replacement in calls, and mark the tail
+ ;; continuations for replacement by K.
+ (for-each (lambda (sym tail arities bodies)
+ (for-each (cut lift-definition! <> term-k dfg)
+ bodies)
+ (subst-call! sym arities bodies)
+ (subst-return! tail k))
+ syms tails arities bodies)
+ k))))
+
+ ;; This is a first cut at a contification algorithm. It contifies
+ ;; non-recursive functions that only have positional arguments.
+ (define (visit-fun term)
+ (rewrite-cps-exp term
+ (($ $fun meta free body)
+ ($fun meta free ,(visit-cont body)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src
+ ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
+ body))
+ (sym src ($kargs () () ,(visit-term body sym))))
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body sym))))
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (sym src ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym src ($ $kclause arity body))
+ (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term term-k)
+ (match term
+ (($ $letk conts body)
+ ;; Visit the body first, so we visit depth-first.
+ (let ((body (visit-term body term-k)))
+ (build-cps-term
+ ($letk ,(map visit-cont conts) ,body))))
+ (($ $letrec names syms funs body)
+ (define (split-components nsf)
+ ;; FIXME: Compute strongly-connected components. Currently
+ ;; we just put non-recursive functions in their own
+ ;; components, and lump everything else in the remaining
+ ;; component.
+ (define (recursive? k)
+ (or-map (cut variable-used-in? <> k dfg) syms))
+ (let lp ((nsf nsf) (rec '()))
+ (match nsf
+ (()
+ (if (null? rec)
+ '()
+ (list rec)))
+ (((and elt (n s ($ $fun meta free ($ $cont kentry))))
+ . nsf)
+ (if (recursive? kentry)
+ (lp nsf (cons elt rec))
+ (cons (list elt) (lp nsf rec)))))))
+ (define (visit-components components)
+ (match components
+ (() (visit-term body term-k))
+ ((((name sym fun) ...) . components)
+ (match fun
+ ((($ $fun meta free
+ ($ $cont fun-k _
+ ($ $kentry self
+ ($ $cont tail-k _ ($ $ktail))
+ (($ $cont _ _ ($ $kclause arity
+ (and body ($ $cont body-k))))
+ ...))))
+ ...)
+ (if (contify-funs term-k sym self tail-k arity body-k)
+ (let ((body* (visit-components components)))
+ (build-cps-term
+ ($letk ,(map visit-cont (concatenate body))
+ ,body*)))
+ (let-gensyms (k)
+ (build-cps-term
+ ($letrec name sym (map visit-fun fun)
+ ,(visit-components components))))))))))
+ (visit-components (split-components (map list names syms funs))))
+ (($ $continue k exp)
+ (let ((k* (lookup-return-cont k)))
+ (define (default)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k* ,(visit-fun exp)))
+ (($ $primcall 'return (val))
+ ,(if (eq? k k*)
+ (build-cps-term ($continue k* ,exp))
+ (build-cps-term ($continue k* ($values (val))))))
+ (($ $primcall 'return-values vals)
+ ,(if (eq? k k*)
+ (build-cps-term ($continue k* ,exp))
+ (build-cps-term ($continue k* ($values vals)))))
+ (_ ($continue k* ,exp))))
+ (match exp
+ (($ $fun meta free
+ ($ $cont fun-k _
+ ($ $kentry self
+ ($ $cont tail-k _ ($ $ktail))
+ (($ $cont _ _ ($ $kclause arity
+ (and body ($ $cont body-k))))
+ ...))))
+ (if (and=> (bound-symbol k*)
+ (lambda (sym)
+ (contify-fun term-k sym self tail-k arity body-k)))
+ (build-cps-term
+ ($letk ,(map visit-cont body)
+ ($continue k* ($values ()))))
+ (default)))
+ (($ $call proc args)
+ (or (contify-call proc args)
+ (default)))
+ (_ (default)))))))
+
+ (let ((fun (visit-fun fun)))
+ (if (null? call-substs)
+ fun
+ ;; Iterate to fixed point.
+ (contify fun)))))
--
1.8.3.2
^ permalink raw reply related [flat|nested] 17+ messages in thread
* Re: CPS language and Tree-IL->CPS->RTL compiler
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (8 preceding siblings ...)
2013-08-29 7:49 ` [PATCH 9/9] Add contification pass Andy Wingo
@ 2013-08-29 20:42 ` Ludovic Courtès
2013-08-31 7:47 ` Andy Wingo
2013-08-29 21:52 ` Noah Lavine
10 siblings, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2013-08-29 20:42 UTC (permalink / raw)
To: guile-devel
Hello!
Andy Wingo <wingo@pobox.com> skribis:
> This patchset implements the CPS compiler I've been working on over the
> last couple months. At the end of it, you can
>
> guild compile -t rtl foo.scm
>
> and, if there are no bugs or unimplemented bits, at that point you have
> a loadable .go with RTL code. (Try readelf -a on the .go!)
Woow, wonderful!
> As a little example:
>
> (+ 1 2)
>
> Here + is a primcall, so we would get:
>
> ($letk ((kone ($kargs (oneb)
> ($letk ((ktwo ($kargs (two)
> ($continue ktail
> ($primcall + one two)))))
> ($continue ktwo ($const 2))))))
> ($continue kone ($const 1)))
>
> Here all CPS language constructs are prefixed with "$". Everything else
> is a variable, except the + in the primcall.
Thanks for the example that nicely complements a first-time read of
Kennedy’s paper.
[...]
> If you ever worked with the old (language tree-il compile-glil) module,
> you know it's very hairy, mostly because it's mixing code emission with
> semantic transformations. Nowhere is this more evident than the
> so-called "labels allocation" strategy, in which we try to allocate
> procedures as basic blocks, if they all return to the same place. It's
> a funky pass. It turns out this concept is well-studied and has a name,
> "contification", and is cleanly expressed as a source-to-source pass
> over CPS. So compile-rtl.scm is dumb: it just loops over all
> expressions, emitting code for each of them, and emitting jumps and
> shuffling registers as needed (based on a prior analysis pass).
That’s really appreciable. :-)
> OK. WDYT, Ludo? Comments? OK to merge? :)
Well, I guess so!
Thanks to Noah for getting you started, and to Mark and you for getting
this far!
(I’m going to browse the patches, mostly so I can learn from this.)
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH 1/9] Add CPS language
2013-08-29 7:49 ` [PATCH 1/9] Add CPS language Andy Wingo
@ 2013-08-29 20:48 ` Ludovic Courtès
0 siblings, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2013-08-29 20:48 UTC (permalink / raw)
To: guile-devel
Looks like a clean foundation to me.
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH 6/9] Add arity-adapting module
2013-08-29 7:49 ` [PATCH 6/9] Add arity-adapting module Andy Wingo
@ 2013-08-29 21:08 ` Ludovic Courtès
2013-08-29 22:26 ` Mark H Weaver
0 siblings, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2013-08-29 21:08 UTC (permalink / raw)
To: guile-devel
Andy Wingo <wingo@pobox.com> skribis:
> +;;; Commentary:
> +;;;
> +;;; A pass to adapt expressions to the arities of their continuations,
> +;;; and to rewrite some tail expressions as primcalls to "return".
> +;;;
> +;;; Code:
[...]
> + (define (adapt-exp nvals k exp)
> + (match nvals
> + (0
> + (rewrite-cps-term (lookup-cont k conts)
> + (($ $ktail)
> + ,(let-gensyms (kvoid kunspec unspec)
> + (build-cps-term
> + ($letk* ((kunspec #f ($kargs (unspec) (unspec)
> + ($continue k
> + ($primcall 'return (unspec)))))
> + (kvoid #f ($kargs () ()
> + ($continue kunspec ($void)))))
> + ($continue kvoid ,exp)))))
[...]
> + (let ((drop-result
> + (lambda (kseq)
> + (let-gensyms (k* drop)
> + (build-cps-term
> + ($letk ((k* #f ($kargs ('drop) (drop)
> + ($continue kseq ($values ())))))
> + ($continue k* ,exp)))))))
Are ($void) and ($values ()) both equivalent to *unspecified*?
> + (rewrite-cps-term (lookup-cont k conts)
> + (($ $ktail)
> + ,(rewrite-cps-term exp
> + (($var sym)
> + ($continue ktail ($primcall 'return (sym))))
> + (_
> + ,(let-gensyms (k* v)
> + (build-cps-term
> + ($letk ((k* #f ($kargs (v) (v)
> + ($continue k
> + ($primcall 'return (v))))))
> + ($continue k* ,exp)))))))
> + (($ $ktrunc ($ $arity () () #f () #f) kseq)
> + ,(drop-result kseq))
> + (($ $kargs () () _)
> + ,(drop-result k))
> + (_
> + ($continue k ,exp)))))))
Perhaps that happens in the Tree-IL->CPS pass, but is there/could there
be an effect analysis when truncating multiple-value returns?
Such that (f (values 1 2 3)) reduces to (f 1).
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: CPS language and Tree-IL->CPS->RTL compiler
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
` (9 preceding siblings ...)
2013-08-29 20:42 ` CPS language and Tree-IL->CPS->RTL compiler Ludovic Courtès
@ 2013-08-29 21:52 ` Noah Lavine
10 siblings, 0 replies; 17+ messages in thread
From: Noah Lavine @ 2013-08-29 21:52 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 6792 bytes --]
Hello,
This is great! I read some patches, and it's much cleaner than mine. I'm
glad we have a cool new CPS compiler now, and we can start to really use
the RTL VM!
Noah
On Thu, Aug 29, 2013 at 3:49 AM, Andy Wingo <wingo@pobox.com> wrote:
> Hi all,
>
> This patchset implements the CPS compiler I've been working on over the
> last couple months. At the end of it, you can
>
> guild compile -t rtl foo.scm
>
> and, if there are no bugs or unimplemented bits, at that point you have
> a loadable .go with RTL code. (Try readelf -a on the .go!)
>
> From the console the way to do it is:
>
> (use-modules (system vm objcode))
> (load-thunk-from-memory (compile foo #:to 'rtl))
>
> That gives you the thunk that, when called, will execute FOO.
>
> So with that intro, some more on CPS and the RTL VM. As you know we
> have a new register-based VM, where all values have names (slots). It's
> appropriate that the language that compiles to this VM also give names
> to all intermediate values. CPS has this property. In addition, CPS
> gives names to all control points, effectively giving a label to each
> expression.
>
> This CPS language was inspired by Andrew Kennedy's great 2007 paper,
> "Compiling with Continuations, Continued". In particular, continuations
> are /local/ to a function, so they really are basic block labels, and
> all values are bound to variables via continuation calls -- even
> constants.
>
> As a little example:
>
> (+ 1 2)
>
> Here + is a primcall, so we would get:
>
> ($letk ((kone ($kargs (oneb)
> ($letk ((ktwo ($kargs (two)
> ($continue ktail
> ($primcall + one two)))))
> ($continue ktwo ($const 2))))))
> ($continue kone ($const 1)))
>
> Here all CPS language constructs are prefixed with "$". Everything else
> is a variable, except the + in the primcall.
>
> As you can see it is incredibly verbose. At the same time it's very
> simple, as there are only two kinds of terms: terms that bind
> continuations, and terms that call continuations.
>
> $letk binds a set of mutually recursive continuations, each one an
> instance of $cont. A $cont declares the name and source of a
> continuation, and then contains as a subterm the particular
> continuation instance: $kif for test continuations, $kargs for
> continuations that bind values, etc.
>
> $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.
>
> Additionally there is $letrec, a term that binds mutually recursive
> functions. The contification pass will turn $letrec into $letk if
> it can do so. Otherwise, the closure conversion pass will desugar
> $letrec into an equivalent sequence of make-closure primcalls and
> subsequent initializations of the captured variables of the
> closures. You can think of $letrec as pertaining to "high CPS",
> whereas later passes will only see "low CPS", which does not have
> $letrec.
>
> There are a bunch of Guile-specific quirks in this language, mostly
> related to function prologues for the different kinds of arities, and
> for things like multiple-value truncation and prompts. Check out
> (language cps) for all the deal.
>
> So, after that patch is the Tree-IL->CPS compiler. It simplifies a
> number of Tree-IL concepts, fixing argument order, turning toplevel
> references to primcalls, transforming prompts, assignment conversion,
> etc. For this reason it's a bit hairy, but it seems to work fine. This
> compiler runs *after* optimization passes on Tree-IL, so you still have
> peval that runs over tree-il.
>
> After that follow a bunch of passes to build up an RTL compiler. The
> idea is to compile by incremental source-to-source passes, and at the
> end you just assign slots to all variables and emit code directly.
>
> If you ever worked with the old (language tree-il compile-glil) module,
> you know it's very hairy, mostly because it's mixing code emission with
> semantic transformations. Nowhere is this more evident than the
> so-called "labels allocation" strategy, in which we try to allocate
> procedures as basic blocks, if they all return to the same place. It's
> a funky pass. It turns out this concept is well-studied and has a name,
> "contification", and is cleanly expressed as a source-to-source pass
> over CPS. So compile-rtl.scm is dumb: it just loops over all
> expressions, emitting code for each of them, and emitting jumps and
> shuffling registers as needed (based on a prior analysis pass).
>
> In the end you can ,disassemble the code, thanks to the earlier RTL
> work.
>
> I don't want people to benchmark this stuff yet -- it's buggy and not
> optimized. Don't use this work for anything serious. But if you're in
> to hacking on it, that's cool. There are a number of optimization
> passes that are needed (see compile-rtl.scm for a list), but currently
> it's looking like the RTL compiler does significantly better on loops,
> but struggles to keep up with the old VM for calls. This is
> unsurprising, as calls really do work like stacks, and a stack VM has
> many advantages there. But we think that with better slot allocation we
> can probably be faster for calls as well.
>
> Thank you, thank you, thank you to Mark Weaver for helping out with this
> work! Without him there would be many more bugs. I've folded all of
> his patches into this patchset, so please consider him the joint author
> of all of this. In any case the bugs have forced him to page much of
> this code into his head so we are better equipped as a project because
> of that ;-)
>
> Thank you also to Noah Lavine, who did an earlier pass at CPS
> conversion. I considered starting from his work but it became clear
> that many aspects of CPS would be nicer with changes in Tree-IL -- so I
> took advantage of my maintenance of the old compiler to make various
> changes there and in other parts of the runtime to get a cleaner CPS
> compiler. In the end we took advantage of his vanguard-hacking, though
> as ideas rather than as code. Thank you Noah!
>
> There are not as many tests and documentation as one would like.
> Ultimately it all just came together in the last couple of weeks, so I
> think the next step is to write more tests and try the compiler on new
> pieces of code. There are a couple bugs that we know about at this
> point, and surely many more that we don't know about. I ask for some
> lenience on this front while we figure out what the compiler should look
> like :)
>
> OK. WDYT, Ludo? Comments? OK to merge? :)
>
> Cheers,
>
> Andy
>
>
>
[-- Attachment #2: Type: text/html, Size: 7708 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH 6/9] Add arity-adapting module
2013-08-29 21:08 ` Ludovic Courtès
@ 2013-08-29 22:26 ` Mark H Weaver
2013-08-31 7:45 ` Andy Wingo
0 siblings, 1 reply; 17+ messages in thread
From: Mark H Weaver @ 2013-08-29 22:26 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Andy Wingo <wingo@pobox.com> skribis:
>
>> +;;; Commentary:
>> +;;;
>> +;;; A pass to adapt expressions to the arities of their continuations,
>> +;;; and to rewrite some tail expressions as primcalls to "return".
>> +;;;
>> +;;; Code:
>
> [...]
>
>> + (define (adapt-exp nvals k exp)
>> + (match nvals
>> + (0
>> + (rewrite-cps-term (lookup-cont k conts)
>> + (($ $ktail)
>> + ,(let-gensyms (kvoid kunspec unspec)
>> + (build-cps-term
>> + ($letk* ((kunspec #f ($kargs (unspec) (unspec)
>> + ($continue k
>> + ($primcall 'return (unspec)))))
>> + (kvoid #f ($kargs () ()
>> + ($continue kunspec ($void)))))
>> + ($continue kvoid ,exp)))))
>
> [...]
>
>> + (let ((drop-result
>> + (lambda (kseq)
>> + (let-gensyms (k* drop)
>> + (build-cps-term
>> + ($letk ((k* #f ($kargs ('drop) (drop)
>> + ($continue kseq ($values ())))))
>> + ($continue k* ,exp)))))))
>
> Are ($void) and ($values ()) both equivalent to *unspecified*?
No. ($void) passes a single value (*unspecified*), to the continuation.
($values ()) passes zero values to the continuation, like (values).
>> + (rewrite-cps-term (lookup-cont k conts)
>> + (($ $ktail)
>> + ,(rewrite-cps-term exp
>> + (($var sym)
>> + ($continue ktail ($primcall 'return (sym))))
>> + (_
>> + ,(let-gensyms (k* v)
>> + (build-cps-term
>> + ($letk ((k* #f ($kargs (v) (v)
>> + ($continue k
>> + ($primcall 'return (v))))))
>> + ($continue k* ,exp)))))))
>> + (($ $ktrunc ($ $arity () () #f () #f) kseq)
>> + ,(drop-result kseq))
>> + (($ $kargs () () _)
>> + ,(drop-result k))
>> + (_
>> + ($continue k ,exp)))))))
>
> Perhaps that happens in the Tree-IL->CPS pass, but is there/could there
> be an effect analysis when truncating multiple-value returns?
>
> Such that (f (values 1 2 3)) reduces to (f 1).
I guess this is a question for Andy, but some experimentation suggests
that this transformation is already done by an earlier optimization pass
in tree-il.
Regards,
Mark
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: [PATCH 6/9] Add arity-adapting module
2013-08-29 22:26 ` Mark H Weaver
@ 2013-08-31 7:45 ` Andy Wingo
0 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-31 7:45 UTC (permalink / raw)
To: Mark H Weaver; +Cc: Ludovic Courtès, guile-devel
On Fri 30 Aug 2013 00:26, Mark H Weaver <mhw@netris.org> writes:
> ludo@gnu.org (Ludovic Courtès) writes:
>
>> Perhaps that happens in the Tree-IL->CPS pass, but is there/could there
>> be an effect analysis when truncating multiple-value returns?
>>
>> Such that (f (values 1 2 3)) reduces to (f 1).
>
> I guess this is a question for Andy, but some experimentation suggests
> that this transformation is already done by an earlier optimization pass
> in tree-il.
Yes, I think it's peval that does this.
scheme@(guile-user)> ,optimize (f (values 1 2 3))
$1 = (f 1)
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 17+ messages in thread
* Re: CPS language and Tree-IL->CPS->RTL compiler
2013-08-29 20:42 ` CPS language and Tree-IL->CPS->RTL compiler Ludovic Courtès
@ 2013-08-31 7:47 ` Andy Wingo
0 siblings, 0 replies; 17+ messages in thread
From: Andy Wingo @ 2013-08-31 7:47 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
On Thu 29 Aug 2013 22:42, ludo@gnu.org (Ludovic Courtès) writes:
>> OK. WDYT, Ludo? Comments? OK to merge? :)
>
> Well, I guess so!
Excellent! Pushed :)
I'll send another mail with a TODO.
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 17+ messages in thread
end of thread, other threads:[~2013-08-31 7:47 UTC | newest]
Thread overview: 17+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2013-08-29 7:49 CPS language and Tree-IL->CPS->RTL compiler Andy Wingo
2013-08-29 7:49 ` [PATCH 1/9] Add CPS language Andy Wingo
2013-08-29 20:48 ` Ludovic Courtès
2013-08-29 7:49 ` [PATCH 2/9] (compile foo #:to 'cps) Andy Wingo
2013-08-29 7:49 ` [PATCH 3/9] Add closure conversion Andy Wingo
2013-08-29 7:49 ` [PATCH 4/9] RTL language Andy Wingo
2013-08-29 7:49 ` [PATCH 5/9] Add CPS primitives info module Andy Wingo
2013-08-29 7:49 ` [PATCH 6/9] Add arity-adapting module Andy Wingo
2013-08-29 21:08 ` Ludovic Courtès
2013-08-29 22:26 ` Mark H Weaver
2013-08-31 7:45 ` Andy Wingo
2013-08-29 7:49 ` [PATCH 7/9] Add pass to reify primcalls without corresponding VM ops Andy Wingo
2013-08-29 7:49 ` [PATCH 8/9] Add CPS -> RTL compiler Andy Wingo
2013-08-29 7:49 ` [PATCH 9/9] Add contification pass Andy Wingo
2013-08-29 20:42 ` CPS language and Tree-IL->CPS->RTL compiler Ludovic Courtès
2013-08-31 7:47 ` Andy Wingo
2013-08-29 21:52 ` Noah Lavine
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).