* [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* 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: [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
* [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: 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