[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-183-g8ac8e2d
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-183-g8ac8e2d |
|
Date: |
Sat, 31 Aug 2013 07:44:00 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8ac8e2dfeb88172deab6fe453d7a2f0ad03729d6
The branch, master has been updated
via 8ac8e2dfeb88172deab6fe453d7a2f0ad03729d6 (commit)
via 6e8ad823359adae643007afb3a4c4f4d91c252e5 (commit)
via 934e6b95159c75fe43dfb1a8e0882d6b88ba4cbf (commit)
via 026b561154faa7a5c6b2ceb7b6ed3b07cb543b00 (commit)
via 045392f1b24475dc6f46123bc7e782958bc7c81d (commit)
via 43f768f48d35e575322d1bfbcc1a39ceb91fe36b (commit)
via 4b8de65e9d3a846bd0e06b36e0c744a77982a92d (commit)
via 4fefc3a867e701b179f54de869acdeec023be2d1 (commit)
via 80b01fd086c7999bc658913264743ea097d614d3 (commit)
from 93009a7acaf172d1e9a8b3763cf83e616567a04f (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 8ac8e2dfeb88172deab6fe453d7a2f0ad03729d6
Author: Andy Wingo <address@hidden>
Date: Sat Aug 24 15:02:57 2013 +0200
Add contification pass
* module/Makefile.am:
* module/language/cps/contification.scm: New pass.
* module/language/cps/compile-rtl.scm (optimize): Wire it into the
compiler.
commit 6e8ad823359adae643007afb3a4c4f4d91c252e5
Author: Andy Wingo <address@hidden>
Date: Sun Aug 11 14:08:08 2013 +0200
Add CPS -> RTL compiler
* 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.
commit 934e6b95159c75fe43dfb1a8e0882d6b88ba4cbf
Author: Andy Wingo <address@hidden>
Date: Sat Aug 24 15:02:52 2013 +0200
Add pass to reify primcalls without corresponding VM ops
* module/Makefile.am:
* module/language/cps/reify-primitives.scm: New pass.
commit 026b561154faa7a5c6b2ceb7b6ed3b07cb543b00
Author: Andy Wingo <address@hidden>
Date: Thu Jul 18 20:02:13 2013 +0200
Add arity-adapting module
* module/Makefile.am:
* module/language/cps/arities.scm: New module. Adapts call and return
arities, especially for primcalls.
commit 045392f1b24475dc6f46123bc7e782958bc7c81d
Author: Andy Wingo <address@hidden>
Date: Sat Aug 24 15:02:38 2013 +0200
Add CPS primitives info module
* module/Makefile.am:
* module/language/cps/primitives.scm: New file.
commit 43f768f48d35e575322d1bfbcc1a39ceb91fe36b
Author: Andy Wingo <address@hidden>
Date: Sun Aug 11 14:06:15 2013 +0200
RTL language
* module/Makefile.am
* module/language/rtl.scm:
* module/language/rtl/spec.scm: Add a stub RTL language.
commit 4b8de65e9d3a846bd0e06b36e0c744a77982a92d
Author: Andy Wingo <address@hidden>
Date: Tue Jul 23 16:05:48 2013 +0200
Add closure conversion
* module/Makefile.am
* module/language/cps/closure-conversion.scm: New module, implementing a
closure conversion pass.
commit 4fefc3a867e701b179f54de869acdeec023be2d1
Author: Andy Wingo <address@hidden>
Date: Tue Jul 23 16:04:51 2013 +0200
(compile foo #:to 'cps)
* 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.
commit 80b01fd086c7999bc658913264743ea097d614d3
Author: Andy Wingo <address@hidden>
Date: Tue Jul 23 15:51:35 2013 +0200
Add CPS language
* 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.
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 27 +-
module/Makefile.am | 20 +
module/language/cps.scm | 469 ++++++++++++++++++++++
module/language/cps/arities.scm | 152 +++++++
module/language/cps/closure-conversion.scm | 273 +++++++++++++
module/language/cps/compile-rtl.scm | 370 +++++++++++++++++
module/language/cps/contification.scm | 238 +++++++++++
module/language/cps/dfg.scm | 432 ++++++++++++++++++++
module/language/cps/primitives.scm | 96 +++++
module/language/cps/reify-primitives.scm | 117 ++++++
module/language/cps/slot-allocation.scm | 419 ++++++++++++++++++++
module/language/{assembly => cps}/spec.scm | 26 +-
module/language/cps/verify.scm | 165 ++++++++
module/language/rtl.scm | 92 +++++
module/language/{value => rtl}/spec.scm | 21 +-
module/language/tree-il/compile-cps.scm | 594 ++++++++++++++++++++++++++++
module/language/tree-il/spec.scm | 4 +-
test-suite/Makefile.am | 1 +
test-suite/tests/rtl-compilation.test | 200 ++++++++++
19 files changed, 3687 insertions(+), 29 deletions(-)
create mode 100644 module/language/cps.scm
create mode 100644 module/language/cps/arities.scm
create mode 100644 module/language/cps/closure-conversion.scm
create mode 100644 module/language/cps/compile-rtl.scm
create mode 100644 module/language/cps/contification.scm
create mode 100644 module/language/cps/dfg.scm
create mode 100644 module/language/cps/primitives.scm
create mode 100644 module/language/cps/reify-primitives.scm
create mode 100644 module/language/cps/slot-allocation.scm
copy module/language/{assembly => cps}/spec.scm (62%)
create mode 100644 module/language/cps/verify.scm
create mode 100644 module/language/rtl.scm
copy module/language/{value => rtl}/spec.scm (68%)
create mode 100644 module/language/tree-il/compile-cps.scm
create mode 100644 test-suite/tests/rtl-compilation.test
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..0e6fdf6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -53,6 +53,8 @@ SOURCES = \
language/glil.scm \
language/assembly.scm \
$(TREE_IL_LANG_SOURCES) \
+ $(CPS_LANG_SOURCES) \
+ $(RTL_LANG_SOURCES) \
$(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
@@ -111,10 +113,28 @@ 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/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 \
+ language/cps/slot-allocation.scm \
+ 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/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/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)))))
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}.
+
address@hidden 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.
address@hidden 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
address@hidden, 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)))))))
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
new file mode 100644
index 0000000..b126738
--- /dev/null
+++ b/module/language/cps/compile-rtl.scm
@@ -0,0 +1,370 @@
+;;; 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 contification)
+ #: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* ((exp (run-pass exp contify #:contify? #t)))
+ ;; Passes that are needed:
+ ;;
+ ;; * 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/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)))))
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/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)))
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)))
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/assembly/spec.scm b/module/language/cps/spec.scm
similarity index 62%
copy from module/language/assembly/spec.scm
copy to module/language/cps/spec.scm
index 0a497e4..493b547 100644
--- a/module/language/assembly/spec.scm
+++ b/module/language/cps/spec.scm
@@ -1,6 +1,6 @@
-;;; Guile Virtual Machine Assembly
+;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; 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
@@ -18,18 +18,20 @@
;;; Code:
-(define-module (language assembly spec)
+(define-module (language cps spec)
#:use-module (system base language)
- #:use-module (language assembly compile-bytecode)
- #:use-module (language assembly decompile-bytecode)
- #:export (assembly))
+ #:use-module (language cps)
+ #:use-module (language cps compile-rtl)
+ #:export (cps))
-(define-language assembly
- #:title "Guile Virtual Machine Assembly Language"
+(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
- #:parser read ;; fixme: make a verifier?
- #:compilers `((bytecode . ,compile-bytecode))
- #:decompilers `((bytecode . ,decompile-bytecode))
+ #:printer write-cps
+ #:parser parse-cps
+ #:compilers `((rtl . ,compile-rtl))
#:for-humans? #f
)
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)
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/value/spec.scm b/module/language/rtl/spec.scm
similarity index 68%
copy from module/language/value/spec.scm
copy to module/language/rtl/spec.scm
index 506b073..0a8c4ee 100644
--- a/module/language/value/spec.scm
+++ b/module/language/rtl/spec.scm
@@ -1,6 +1,6 @@
-;;; Guile Lowlevel Intermediate Language
+;;; Register Transfer Language (RTL)
-;; Copyright (C) 2001, 2010, 2013 Free Software Foundation, Inc.
+;; 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
@@ -18,13 +18,14 @@
;;; Code:
-(define-module (language value spec)
+(define-module (language rtl spec)
#:use-module (system base language)
- #:export (value))
+ #:use-module (ice-9 binary-ports)
+ #:export (rtl))
-(define-language value
- #:title "Values"
- #:reader #f
- #:printer write
- #:for-humans? #f
- )
+(define-language rtl
+ #:title "Register Transfer Language"
+ #:compilers '()
+ #:printer (lambda (rtl port) (put-bytevector port rtl))
+ #:reader get-bytevector-all
+ #: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
)
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))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-183-g8ac8e2d,
Andy Wingo <=