[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 8/9] Add CPS -> RTL compiler
|
From: |
Andy Wingo |
|
Subject: |
[PATCH 8/9] Add CPS -> RTL compiler |
|
Date: |
Thu, 29 Aug 2013 09:49:38 +0200 |
* module/Makefile.am:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/slot-allocation.scm: New modules.
* module/language/cps/spec.scm: Register the compiler.
* test-suite/Makefile.am:
* test-suite/tests/rtl-compilation.test: Add tests.
---
module/Makefile.am | 3 +
module/language/cps/compile-rtl.scm | 371 +++++++++++++++++++++++++++
module/language/cps/dfg.scm | 432 ++++++++++++++++++++++++++++++++
module/language/cps/slot-allocation.scm | 419 +++++++++++++++++++++++++++++++
module/language/cps/spec.scm | 3 +-
test-suite/Makefile.am | 1 +
test-suite/tests/rtl-compilation.test | 200 +++++++++++++++
7 files changed, 1428 insertions(+), 1 deletion(-)
create mode 100644 module/language/cps/compile-rtl.scm
create mode 100644 module/language/cps/dfg.scm
create mode 100644 module/language/cps/slot-allocation.scm
create mode 100644 test-suite/tests/rtl-compilation.test
diff --git a/module/Makefile.am b/module/Makefile.am
index d7e524b..5a0ff69 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -122,8 +122,11 @@ CPS_LANG_SOURCES =
\
language/cps.scm \
language/cps/arities.scm \
language/cps/closure-conversion.scm \
+ language/cps/compile-rtl.scm \
+ language/cps/dfg.scm \
language/cps/primitives.scm \
language/cps/reify-primitives.scm \
+ language/cps/slot-allocation.scm \
language/cps/spec.scm \
language/cps/verify.scm
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
new file mode 100644
index 0000000..9277adf
--- /dev/null
+++ b/module/language/cps/compile-rtl.scm
@@ -0,0 +1,371 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; Compiling CPS to RTL. The result is in the RTL language, which
+;;; happens to be an ELF image as a bytecode.
+;;;
+;;; Code:
+
+(define-module (language cps compile-rtl)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps arities)
+ #:use-module (language cps closure-conversion)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language cps reify-primitives)
+ #:use-module (language cps slot-allocation)
+ #:use-module (system vm assembler)
+ #:export (compile-rtl))
+
+;; TODO: Source info, local var names. Needs work in the linker and the
+;; debugger.
+
+(define (kw-arg-ref args kw default)
+ (match (memq kw args)
+ ((_ val . _) val)
+ (_ default)))
+
+(define (optimize exp opts)
+ (define (run-pass exp pass kw default)
+ (if (kw-arg-ref opts kw default)
+ (pass exp)
+ exp))
+
+ ;; Calls to source-to-source optimization passes go here.
+ (let* ()
+ ;; Passes that are needed:
+ ;;
+ ;; * Contification: turning $letrec-bound $funs into $letk-bound $conts.
+ ;;
+ ;; * Abort contification: turning abort primcalls into continuation
+ ;; calls, and eliding prompts if possible.
+ ;;
+ ;; * Common subexpression elimination. Desperately needed. Requires
+ ;; effects analysis.
+ ;;
+ ;; * Loop peeling. Unrolls the first round through a loop if the
+ ;; loop has effects that CSE can work on. Requires effects
+ ;; analysis. When run before CSE, loop peeling is the equivalent
+ ;; of loop-invariant code motion (LICM).
+ ;;
+ ;; * Generic simplification pass, to be run as needed. Used to
+ ;; "clean up", both on the original raw input and after specific
+ ;; optimization passes.
+
+ exp))
+
+(define (visit-funs proc exp)
+ (match exp
+ (($ $continue _ exp)
+ (visit-funs proc exp))
+
+ (($ $fun meta free body)
+ (proc exp)
+ (visit-funs proc body))
+
+ (($ $letk conts body)
+ (visit-funs proc body)
+ (for-each (lambda (cont) (visit-funs proc cont)) conts))
+
+ (($ $cont sym src ($ $kargs names syms body))
+ (visit-funs proc body))
+
+ (($ $cont sym src ($ $kclause arity body))
+ (visit-funs proc body))
+
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (for-each (lambda (clause) (visit-funs proc clause)) clauses))
+
+ (_ (values))))
+
+(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
+ (define (slot sym)
+ (lookup-slot sym allocation))
+
+ (define (constant sym)
+ (lookup-constant-value sym allocation))
+
+ (define (emit-rtl label k exp next-label)
+ (define (maybe-mov dst src)
+ (unless (= dst src)
+ (emit-mov asm dst src)))
+
+ (define (maybe-jump label)
+ (unless (eq? label next-label)
+ (emit-br asm label)))
+
+ (define (maybe-load-constant slot src)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value src allocation))
+ (lambda (has-const? val)
+ (and has-const?
+ (begin
+ (emit-load-constant asm slot val)
+ #t)))))
+
+ (define (emit-tail)
+ ;; There are only three kinds of expressions in tail position:
+ ;; tail calls, multiple-value returns, and single-value returns.
+ (match exp
+ (($ $call proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call asm (1+ (length args))))
+ (($ $values args)
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-reset-frame asm (1+ (length args)))
+ (emit-return-values asm))
+ (($ $primcall 'return (arg))
+ (emit-return asm (slot arg)))))
+
+ (define (emit-val sym)
+ (let ((dst (slot sym)))
+ (match exp
+ (($ $var sym)
+ (maybe-mov dst (slot sym)))
+ (($ $void)
+ (when dst
+ (emit-load-constant asm dst *unspecified*)))
+ (($ $const exp)
+ (when dst
+ (emit-load-constant asm dst exp)))
+ (($ $fun meta () ($ $cont k))
+ (emit-load-static-procedure asm dst k))
+ (($ $fun meta free ($ $cont k))
+ (emit-make-closure asm dst k (length free)))
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive asm dst proc-slot nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args))))))
+ (($ $primcall 'current-module)
+ (emit-current-module asm dst))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (constant bound?)))
+ (($ $primcall 'cached-module-box (mod name public? bound?))
+ (emit-cached-module-box asm dst (constant mod) (constant name)
+ (constant public?) (constant bound?)))
+ (($ $primcall 'resolve (name bound?))
+ (emit-resolve asm dst (constant bound?) (slot name)))
+ (($ $primcall 'free-ref (closure idx))
+ (emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall name args)
+ ;; FIXME: Inline all the cases.
+ (let ((inst (prim-rtl-instruction name)))
+ (emit-text asm `((,inst ,dst ,@(map slot args))))))
+ (($ $values (arg))
+ (or (maybe-load-constant dst arg)
+ (maybe-mov dst (slot arg))))
+ (($ $prompt escape? tag handler)
+ (emit-prompt asm escape? tag handler)))
+ (maybe-jump k)))
+
+ (define (emit-vals syms)
+ (match exp
+ (($ $primcall name args)
+ (error "unimplemented primcall in values context" name))
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant (map slot syms) args)))
+ (maybe-jump k))
+
+ (define (emit-seq)
+ (match exp
+ (($ $primcall 'cache-current-module! (sym scope))
+ (emit-cache-current-module! asm (slot sym) (constant scope)))
+ (($ $primcall 'free-set! (closure idx value))
+ (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+ (($ $primcall 'box-set! (box value))
+ (emit-box-set! asm (slot box) (slot value)))
+ (($ $primcall 'struct-set! (struct index value))
+ (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (($ $primcall 'vector-set! (vector index value))
+ (emit-vector-set asm (slot vector) (slot index) (slot value)))
+ (($ $primcall 'set-car! (pair value))
+ (emit-set-car! asm (slot pair) (slot value)))
+ (($ $primcall 'set-cdr! (pair value))
+ (emit-set-cdr! asm (slot pair) (slot value)))
+ (($ $primcall 'define! (sym value))
+ (emit-define asm (slot sym) (slot value)))
+ (($ $primcall name args)
+ (error "unhandled primcall in seq context" name))
+ (($ $values ()) #f))
+ (maybe-jump k))
+
+ (define (emit-test kt kf)
+ (define (unary op sym)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot sym) #t kf))
+ (else
+ (op asm (slot sym) #f kt)
+ (maybe-jump kf))))
+ (define (binary op a b)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot a) (slot b) #t kf))
+ (else
+ (op asm (slot a) (slot b) #f kt)
+ (maybe-jump kf))))
+ (match exp
+ (($ $var sym) (unary emit-br-if-true sym))
+ (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+ (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+ (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+ (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+ (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+ ;; Add TC7 tests here
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+ (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+ (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+ (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+ (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+ (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+ (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+
+ (define (emit-trunc nreq rest? k)
+ (match exp
+ (($ $call proc args)
+ (let ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (length args)))
+ (or (maybe-load-constant proc-slot proc)
+ (maybe-mov proc-slot (slot proc)))
+ (let lp ((n (1+ proc-slot)) (args args))
+ (match args
+ (()
+ (emit-call asm proc-slot (+ nargs 1))
+ (emit-receive-values asm proc-slot nreq)
+ (when rest?
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (emit-reset-frame asm nlocals))
+ ((arg . args)
+ (or (maybe-load-constant n arg)
+ (maybe-mov n (slot arg)))
+ (lp (1+ n) args)))))))
+ (maybe-jump k))
+
+ (match (lookup-cont k cont-table)
+ (($ $ktail) (emit-tail))
+ (($ $kargs (name) (sym)) (emit-val sym))
+ (($ $kargs () ()) (emit-seq))
+ (($ $kargs names syms) (emit-vals syms))
+ (($ $kargs (name) (sym)) (emit-val sym))
+ (($ $kif kt kf) (emit-test kt kf))
+ (($ $ktrunc ($ $arity req () rest () #f) k)
+ (emit-trunc (length req) (and rest #t) k))))
+
+ (define (collect-exps k src cont tail)
+ (define (find-exp k src term)
+ (match term
+ (($ $continue exp-k exp)
+ (cons (list k src exp-k exp) tail))
+ (($ $letk conts body)
+ (find-exp k src body))))
+ (match cont
+ (($ $kargs names syms body)
+ (find-exp k src body))
+ (_ tail)))
+
+ (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
+ (match exps
+ (() #t)
+ (((k src exp-k exp) . exps)
+ (let ((next-label (match exps
+ (((k . _) . _) k)
+ (() #f))))
+ (emit-label asm k)
+ (emit-rtl k exp-k exp next-label)
+ (lp exps))))))
+
+(define (compile-fun f asm)
+ (let ((allocation (allocate-slots f))
+ (cont-table (match f
+ (($ $fun meta free body)
+ (build-local-cont-table body)))))
+ (define (emit-fun-clause clause alternate)
+ (match clause
+ (($ $cont k src
+ ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+ body))
+ (let ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (nlocals (lookup-nlocals k allocation)))
+ (emit-label asm k)
+ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+ nlocals alternate)
+ (emit-rtl-sequence asm body allocation nlocals cont-table)
+ (emit-end-arity asm)))))
+
+ (define (emit-fun-clauses clauses)
+ (match clauses
+ ((clause . clauses)
+ (let ((kalternate (match clauses
+ (() #f)
+ ((($ $cont k) . _) k))))
+ (emit-fun-clause clause kalternate)
+ (when kalternate
+ (emit-fun-clauses clauses))))))
+
+ (match f
+ (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
+ (emit-begin-program asm k (or meta '()))
+ (emit-fun-clauses clauses)
+ (emit-end-program asm)))))
+
+(define (compile-rtl exp env opts)
+ (let* ((exp (fix-arities exp))
+ (exp (optimize exp opts))
+ (exp (convert-closures exp))
+ (exp (reify-primitives exp))
+ (asm (make-assembler)))
+ (visit-funs (lambda (fun)
+ (compile-fun fun asm))
+ exp)
+ (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
+ env
+ env)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
new file mode 100644
index 0000000..0826451
--- /dev/null
+++ b/module/language/cps/dfg.scm
@@ -0,0 +1,432 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; Many passes rely on a local or global static analysis of a function.
+;;; This module implements a simple data-flow graph (DFG) analysis,
+;;; tracking the definitions and uses of variables and continuations.
+;;; It also builds a table of continuations and parent links, to be able
+;;; to easily determine if one continuation is in the scope of another,
+;;; and to get to the expression inside a continuation.
+;;;
+;;; Note that the data-flow graph of continuation labels is a
+;;; control-flow graph.
+;;;
+;;; We currently don't expose details of the DFG type outside this
+;;; module, preferring to only expose accessors. That may change in the
+;;; future but it seems to work for now.
+;;;
+;;; Code:
+
+(define-module (language cps dfg)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (build-cont-table
+ build-local-cont-table
+ lookup-cont
+
+ compute-dfg
+ dfg-cont-table
+ lookup-def
+ lookup-uses
+ find-call
+ call-expression
+ find-expression
+ find-defining-expression
+ find-constant-value
+ lift-definition!
+ variable-used-in?
+ constant-needs-allocation?
+ dead-after-def?
+ dead-after-use?
+ branch?
+ find-other-branches
+ dead-after-branch?
+ lookup-bound-syms))
+
+(define (build-cont-table fun)
+ (fold-conts (lambda (k src cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ fun))
+
+(define (build-local-cont-table cont)
+ (fold-local-conts (lambda (k src cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ cont))
+
+(define (lookup-cont sym conts)
+ (let ((res (hashq-ref conts sym)))
+ (unless res
+ (error "Unknown continuation!" sym (hash-fold acons '() conts)))
+ res))
+
+;; Data-flow graph for CPS: both for values and continuations.
+(define-record-type $dfg
+ (make-dfg conts use-maps uplinks)
+ dfg?
+ ;; hash table of sym -> $kargs, $kif, etc
+ (conts dfg-cont-table)
+ ;; hash table of sym -> $use-map
+ (use-maps dfg-use-maps)
+ ;; hash table of sym -> $parent-link
+ (uplinks dfg-uplinks))
+
+(define-record-type $use-map
+ (make-use-map sym def uses)
+ use-map?
+ (sym use-map-sym)
+ (def use-map-def)
+ (uses use-map-uses set-use-map-uses!))
+
+(define-record-type $uplink
+ (make-uplink parent level)
+ uplink?
+ (parent uplink-parent)
+ (level uplink-level))
+
+(define (visit-fun fun conts use-maps uplinks global?)
+ (define (add-def! sym def-k)
+ (unless def-k
+ (error "Term outside labelled continuation?"))
+ (hashq-set! use-maps sym (make-use-map sym def-k '())))
+
+ (define (add-use! sym use-k)
+ (match (hashq-ref use-maps sym)
+ (#f (error "Symbol out of scope?" sym))
+ ((and use-map ($ $use-map sym def uses))
+ (set-use-map-uses! use-map (cons use-k uses)))))
+
+ (define (link-parent! k parent)
+ (match (hashq-ref uplinks parent)
+ (($ $uplink _ level)
+ (hashq-set! uplinks k (make-uplink parent (1+ level))))))
+
+ (define (visit exp exp-k)
+ (define (def! sym)
+ (add-def! sym exp-k))
+ (define (use! sym)
+ (add-use! sym exp-k))
+ (define (recur exp)
+ (visit exp exp-k))
+ (match exp
+ (($ $letk (($ $cont k src cont) ...) body)
+ ;; Set up recursive environment before visiting cont bodies.
+ (for-each (lambda (cont k)
+ (def! k)
+ (hashq-set! conts k cont)
+ (link-parent! k exp-k))
+ cont k)
+ (for-each visit cont k)
+ (recur body))
+
+ (($ $kargs names syms body)
+ (for-each def! syms)
+ (recur body))
+
+ (($ $kif kt kf)
+ (use! kt)
+ (use! kf))
+
+ (($ $ktrunc arity k)
+ (use! k))
+
+ (($ $letrec names syms funs body)
+ (unless global?
+ (error "$letrec should not be present when building a local DFG"))
+ (for-each def! syms)
+ (for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
+ (visit body exp-k))
+
+ (($ $continue k exp)
+ (use! k)
+ (match exp
+ (($ $var sym)
+ (use! sym))
+
+ (($ $call proc args)
+ (use! proc)
+ (for-each use! args))
+
+ (($ $primcall name args)
+ (for-each use! args))
+
+ (($ $values args)
+ (for-each use! args))
+
+ (($ $prompt escape? tag handler)
+ (use! tag)
+ (use! handler))
+
+ (($ $fun)
+ (when global?
+ (visit-fun exp conts use-maps uplinks global?)))
+
+ (_ #f)))))
+
+ (match fun
+ (($ $fun meta free
+ ($ $cont kentry src
+ (and entry
+ ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ ;; Treat the fun continuation as its own parent.
+ (add-def! kentry kentry)
+ (add-def! self kentry)
+ (hashq-set! uplinks kentry (make-uplink #f 0))
+ (hashq-set! conts kentry entry)
+
+ (add-def! ktail kentry)
+ (hashq-set! conts ktail tail)
+ (link-parent! ktail kentry)
+
+ (for-each
+ (match-lambda
+ (($ $cont kclause _
+ (and clause ($ $kclause arity ($ $cont kbody _ body))))
+ (add-def! kclause kentry)
+ (hashq-set! conts kclause clause)
+ (link-parent! kclause kentry)
+
+ (add-def! kbody kclause)
+ (hashq-set! conts kbody body)
+ (link-parent! kbody kclause)
+
+ (visit body kbody)))
+ clauses))))
+
+(define* (compute-dfg fun #:key (global? #t))
+ (let* ((conts (make-hash-table))
+ (use-maps (make-hash-table))
+ (uplinks (make-hash-table)))
+ (visit-fun fun conts use-maps uplinks global?)
+ (make-dfg conts use-maps uplinks)))
+
+(define (lookup-uplink k uplinks)
+ (let ((res (hashq-ref uplinks k)))
+ (unless res
+ (error "Unknown continuation!" k (hash-fold acons '() uplinks)))
+ res))
+
+(define (lookup-use-map sym use-maps)
+ (let ((res (hashq-ref use-maps sym)))
+ (unless res
+ (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
+ res))
+
+(define (lookup-def sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ def)))))
+
+(define (lookup-uses sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ uses)))))
+
+(define (find-defining-term sym dfg)
+ (match (lookup-uses (lookup-def sym dfg) dfg)
+ ((def-exp-k)
+ (lookup-cont def-exp-k (dfg-cont-table dfg)))
+ (else #f)))
+
+(define (find-call term)
+ (match term
+ (($ $kargs names syms body) (find-call body))
+ (($ $letk conts body) (find-call body))
+ (($ $letrec names syms funs body) (find-call body))
+ (($ $continue) term)))
+
+(define (call-expression call)
+ (match call
+ (($ $continue k exp) exp)))
+
+(define (find-expression term)
+ (call-expression (find-call term)))
+
+(define (find-defining-expression sym dfg)
+ (match (find-defining-term sym dfg)
+ (#f #f)
+ (($ $ktrunc) #f)
+ (term (find-expression term))))
+
+(define (find-constant-value sym dfg)
+ (match (find-defining-expression sym dfg)
+ (($ $const val)
+ (values #t val))
+ (($ $continue k ($ $void))
+ (values #t *unspecified*))
+ (else
+ (values #f #f))))
+
+(define (constant-needs-allocation? sym val dfg)
+ (define (find-exp term)
+ (match term
+ (($ $kargs names syms body) (find-exp body))
+ (($ $letk conts body) (find-exp body))
+ (else term)))
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map _ def uses)
+ (or-map
+ (lambda (use)
+ (match (find-expression (lookup-cont use conts))
+ (($ $call) #f)
+ (($ $values) #f)
+ (($ $primcall 'free-ref (closure slot))
+ (not (eq? sym slot)))
+ (($ $primcall 'free-set! (closure slot value))
+ (not (eq? sym slot)))
+ (($ $primcall 'cache-current-module! (mod . _))
+ (eq? sym mod))
+ (($ $primcall 'cached-toplevel-box _)
+ #f)
+ (($ $primcall 'cached-module-box _)
+ #f)
+ (($ $primcall 'resolve (name bound?))
+ (eq? sym name))
+ (_ #t)))
+ uses))))))
+
+(define (continuation-scope-contains? parent-k k uplinks)
+ (match (lookup-uplink parent-k uplinks)
+ (($ $uplink _ parent-level)
+ (let lp ((k k))
+ (or (eq? parent-k k)
+ (match (lookup-uplink k uplinks)
+ (($ $uplink parent level)
+ (and (< parent-level level)
+ (lp parent)))))))))
+
+(define (lift-definition! k parent-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-uplink parent-k uplinks)
+ (($ $uplink parent level)
+ (hashq-set! uplinks k
+ (make-uplink parent-k (1+ level)))
+ ;; Lift definitions of all conts in K.
+ (let lp ((cont (lookup-cont k conts)))
+ (match cont
+ (($ $letk (($ $cont kid) ...) body)
+ (for-each (cut lift-definition! <> k dfg) kid)
+ (lp body))
+ (($ $letrec names syms funs body)
+ (lp body))
+ (_ #t))))))))
+
+(define (variable-used-in? var parent-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (or-map (lambda (use)
+ (continuation-scope-contains? parent-k use uplinks))
+ (match (lookup-use-map var use-maps)
+ (($ $use-map sym def uses)
+ uses))))))
+
+;; Does k1 dominate k2?
+;;
+;; Note that this is a conservative predicate: a false return value does
+;; not indicate that k1 _doesn't_ dominate k2. The reason for this is
+;; that we are using the scope tree as an approximation of the dominator
+;; relationship. See
+;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
+;; deeper discussion.
+(define (conservatively-dominates? k1 k2 uplinks)
+ (continuation-scope-contains? k1 k2 uplinks))
+
+(define (dead-after-def? sym dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ (null? uses))))))
+
+(define (dead-after-use? sym use-k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ ;; If all other uses dominate this use, it is now dead. There
+ ;; are other ways for it to be dead, but this is an
+ ;; approximation. A better check would be if the successor
+ ;; post-dominates all uses.
+ (and-map (cut conservatively-dominates? <> use-k uplinks)
+ uses))))))
+
+;; A continuation is a "branch" if all of its predecessors are $kif
+;; continuations.
+(define (branch? k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map k use-maps)
+ (($ $use-map sym def uses)
+ (and (not (null? uses))
+ (and-map (lambda (k)
+ (match (lookup-cont k conts)
+ (($ $kif) #t)
+ (_ #f)))
+ uses)))))))
+
+(define (find-other-branches k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map k use-maps)
+ (($ $use-map sym def (uses ..1))
+ (map (lambda (kif)
+ (match (lookup-cont kif conts)
+ (($ $kif (? (cut eq? <> k)) kf)
+ kf)
+ (($ $kif kt (? (cut eq? <> k)))
+ kt)
+ (_ (error "Not all predecessors are branches"))))
+ uses))))))
+
+(define (dead-after-branch? sym branch other-branches dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map sym def uses)
+ (and-map
+ (lambda (use-k)
+ ;; A symbol is dead after a branch if at least one of the
+ ;; other branches dominates a use of the symbol, and all
+ ;; other uses of the symbol dominate the test.
+ (if (or-map (cut conservatively-dominates? <> use-k uplinks)
+ other-branches)
+ (not (conservatively-dominates? branch use-k uplinks))
+ (conservatively-dominates? use-k branch uplinks)))
+ uses))))))
+
+(define (lookup-bound-syms k dfg)
+ (match dfg
+ (($ $dfg conts use-maps uplinks)
+ (match (lookup-cont k conts)
+ (($ $kargs names syms body)
+ syms)))))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
new file mode 100644
index 0000000..a7b9f74
--- /dev/null
+++ b/module/language/cps/slot-allocation.scm
@@ -0,0 +1,419 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; A module to assign stack slots to variables in a CPS term.
+;;;
+;;; Code:
+
+(define-module (language cps slot-allocation)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (allocate-slots
+ lookup-slot
+ lookup-constant-value
+ lookup-maybe-constant-value
+ lookup-nlocals
+ lookup-call-proc-slot
+ lookup-parallel-moves))
+
+;; Continuations can bind variables. The $allocation structure
+;; represents the slot in which a variable is stored.
+;;
+;; Not all variables have slots allocated. Variables that are constant
+;; and that are only used by primcalls that can accept constants
+;; directly are not allocated to slots, and their SLOT value is false.
+;; Likewise constants that are only used by calls are not allocated into
+;; slots, to avoid needless copying. If a variable is constant, its
+;; constant value is set to the CONST slot and HAS-CONST? is set to a
+;; true value.
+;;
+;; DEF holds the label of the continuation that defines the variable,
+;; and DEAD is a list of continuations at which the variable becomes
+;; dead.
+(define-record-type $allocation
+ (make-allocation def slot dead has-const? const)
+ allocation?
+ (def allocation-def)
+ (slot allocation-slot)
+ (dead allocation-dead set-allocation-dead!)
+ (has-const? allocation-has-const?)
+ (const allocation-const))
+
+;; Continuations can also have associated allocation data. For example,
+;; when a call happens in a labelled continuation, we need to know what
+;; slot the procedure goes in. Likewise before branching to the target
+;; continuation, we might need to shuffle values into the right place: a
+;; parallel move. $cont-allocation stores allocation data keyed on the
+;; continuation label.
+(define-record-type $cont-allocation
+ (make-cont-allocation call-proc-slot parallel-moves)
+ cont-allocation?
+
+ ;; Currently calls are allocated in the caller frame, above all locals
+ ;; that are live at the time of the call. Therefore there is no
+ ;; parallel move problem. We could be more clever here.
+ (call-proc-slot cont-call-proc-slot)
+
+ ;; Tail calls, multiple-value returns, and jumps to continuations with
+ ;; multiple arguments are forms of parallel assignment. A
+ ;; $parallel-move represents a specific solution to the parallel
+ ;; assignment problem, with an ordered list of (SRC . DST) moves. This
+ ;; may involve a temporary variable.
+ ;;
+ ;; ((src . dst) ...)
+ (parallel-moves cont-parallel-moves))
+
+(define (find-first-zero n)
+ ;; Naive implementation.
+ (let lp ((slot 0))
+ (if (logbit? slot n)
+ (lp (1+ slot))
+ slot)))
+
+(define (find-first-trailing-zero n count)
+ (let lp ((slot count))
+ (if (or (zero? slot) (logbit? (1- slot) n))
+ slot
+ (lp (1- slot)))))
+
+(define (lookup-allocation sym allocation)
+ (let ((res (hashq-ref allocation sym)))
+ (unless res
+ (error "Variable or continuation not defined" sym))
+ res))
+
+(define (lookup-slot sym allocation)
+ (match (lookup-allocation sym allocation)
+ (($ $allocation def slot dead has-const? const) slot)))
+
+(define (lookup-constant-value sym allocation)
+ (match (lookup-allocation sym allocation)
+ (($ $allocation def slot dead #t const) const)
+ (_
+ (error "Variable does not have constant value" sym))))
+
+(define (lookup-maybe-constant-value sym allocation)
+ (match (lookup-allocation sym allocation)
+ (($ $allocation def slot dead has-const? const)
+ (values has-const? const))))
+
+(define (lookup-call-proc-slot k allocation)
+ (match (lookup-allocation k allocation)
+ (($ $cont-allocation proc-slot parallel-moves)
+ (unless proc-slot
+ (error "Continuation not a call" k))
+ proc-slot)
+ (_
+ (error "Continuation not a call" k))))
+
+(define (lookup-nlocals k allocation)
+ (match (lookup-allocation k allocation)
+ ((? number? nlocals) nlocals)
+ (_
+ (error "Not a clause continuation" k))))
+
+(define (lookup-parallel-moves k allocation)
+ (match (lookup-allocation k allocation)
+ (($ $cont-allocation proc-slot parallel-moves)
+ (unless parallel-moves
+ (error "Continuation does not have parallel moves" k))
+ parallel-moves)
+ (_
+ (error "Continuation not a call" k))))
+
+(define (solve-parallel-move src dst tmp)
+ "Solve the parallel move problem between src and dst slot lists, which
+are comparable with eqv?. A tmp slot may be used."
+
+ ;; This algorithm is taken from: "Tilting at windmills with Coq:
+ ;; formal verification of a compilation algorithm for parallel moves"
+ ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
+ ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
+
+ (define (split-move moves reg)
+ (let loop ((revhead '()) (tail moves))
+ (match tail
+ (((and s+d (s . d)) . rest)
+ (if (eqv? s reg)
+ (cons d (append-reverse revhead rest))
+ (loop (cons s+d revhead) rest)))
+ (_ #f))))
+
+ (define (replace-last-source reg moves)
+ (match moves
+ ((moves ... (s . d))
+ (append moves (list (cons reg d))))))
+
+ (let loop ((to-move (map cons src dst))
+ (being-moved '())
+ (moved '())
+ (last-source #f))
+ ;; 'last-source' should always be equivalent to:
+ ;; (and (pair? being-moved) (car (last being-moved)))
+ (match being-moved
+ (() (match to-move
+ (() (reverse moved))
+ (((and s+d (s . d)) . t1)
+ (if (or (eqv? s d) ; idempotent
+ (not s)) ; src is a constant and can be loaded directly
+ (loop t1 '() moved #f)
+ (loop t1 (list s+d) moved s)))))
+ (((and s+d (s . d)) . b)
+ (match (split-move to-move d)
+ ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
+ (#f (match b
+ (() (loop to-move '() (cons s+d moved) #f))
+ (_ (if (eqv? d last-source)
+ (loop to-move
+ (replace-last-source tmp b)
+ (cons s+d (acons d tmp moved))
+ tmp)
+ (loop to-move b (cons s+d moved) last-source))))))))))
+
+(define (allocate-slots fun)
+ (define (empty-live-set)
+ (cons #b0 '()))
+
+ (define (add-live-variable sym slot live-set)
+ (cons (logior (car live-set) (ash 1 slot))
+ (acons sym slot (cdr live-set))))
+
+ (define (remove-live-variable sym slot live-set)
+ (cons (logand (car live-set) (lognot (ash 1 slot)))
+ (acons sym #f (cdr live-set))))
+
+ (define (fold-live-set proc seed live-set)
+ (let lp ((bits (car live-set)) (clauses (cdr live-set)) (seed seed))
+ (if (zero? bits)
+ seed
+ (match clauses
+ (((sym . slot) . clauses)
+ (if (and slot (logbit? slot bits))
+ (lp (logand bits (lognot (ash 1 slot)))
+ clauses
+ (proc sym slot seed))
+ (lp bits clauses seed)))))))
+
+ (define (compute-slot live-set hint)
+ (if (and hint (not (logbit? hint (car live-set))))
+ hint
+ (find-first-zero (car live-set))))
+
+ (define (compute-call-proc-slot live-set nlocals)
+ (+ 3 (find-first-trailing-zero (car live-set) nlocals)))
+
+ (define dfg (compute-dfg fun #:global? #f))
+ (define allocation (make-hash-table))
+
+ (define (visit-clause clause live-set)
+ (define nlocals (compute-slot live-set #f))
+ (define nargs
+ (match clause
+ (($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
+ (length syms))))
+
+ (define (allocate! sym k hint live-set)
+ (match (hashq-ref allocation sym)
+ (($ $allocation def slot dead has-const)
+ ;; Parallel move already allocated this one.
+ (if slot
+ (add-live-variable sym slot live-set)
+ live-set))
+ (_
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? const)
+ (cond
+ ((and has-const? (not (constant-needs-allocation? sym const
dfg)))
+ (hashq-set! allocation sym
+ (make-allocation k #f '() has-const? const))
+ live-set)
+ (else
+ (let ((slot (compute-slot live-set hint)))
+ (when (>= slot nlocals)
+ (set! nlocals (+ slot 1)))
+ (hashq-set! allocation sym
+ (make-allocation k slot '() has-const? const))
+ (add-live-variable sym slot live-set)))))))))
+
+ (define (dead sym k live-set)
+ (match (lookup-allocation sym allocation)
+ ((and allocation ($ $allocation def slot dead has-const? const))
+ (set-allocation-dead! allocation (cons k dead))
+ (remove-live-variable sym slot live-set))))
+
+ (define (allocate-frame! k nargs live-set)
+ (let ((proc-slot (compute-call-proc-slot live-set nlocals)))
+ (set! nlocals (max nlocals (+ proc-slot 1 nargs)))
+ (hashq-set! allocation k
+ (make-cont-allocation
+ proc-slot
+ (match (hashq-ref allocation k)
+ (($ $cont-allocation #f moves) moves)
+ (#f #f))))
+ live-set))
+
+ (define (parallel-move! src-k src-slots pre-live-set post-live-set
dst-slots)
+ (let* ((tmp-slot (find-first-zero (logior (car pre-live-set)
+ (car post-live-set))))
+ (moves (solve-parallel-move src-slots dst-slots tmp-slot)))
+ (when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
+ (set! nlocals (+ tmp-slot 1)))
+ (hashq-set! allocation src-k
+ (make-cont-allocation
+ (match (hashq-ref allocation src-k)
+ (($ $cont-allocation proc-slot #f) proc-slot)
+ (#f #f))
+ moves))
+ post-live-set))
+
+ (define (visit-cont cont label live-set)
+ (define (maybe-kill-definition sym live-set)
+ (if (and (lookup-slot sym allocation) (dead-after-def? sym dfg))
+ (dead sym label live-set)
+ live-set))
+
+ (define (kill-conditionally-dead live-set)
+ (if (branch? label dfg)
+ (let ((branches (find-other-branches label dfg)))
+ (fold-live-set
+ (lambda (sym slot live-set)
+ (if (and (> slot nargs)
+ (dead-after-branch? sym label branches dfg))
+ (dead sym label live-set)
+ live-set))
+ live-set
+ live-set))
+ live-set))
+
+ (match cont
+ (($ $kentry self tail clauses)
+ (let ((live-set (allocate! self label 0 live-set)))
+ (for-each (cut visit-cont <> label live-set) clauses))
+ live-set)
+
+ (($ $kclause arity ($ $cont k src body))
+ (visit-cont body k live-set))
+
+ (($ $kargs names syms body)
+ (visit-term body label
+ (kill-conditionally-dead
+ (fold maybe-kill-definition
+ (fold (cut allocate! <> label #f <>) live-set syms)
+ syms))))
+
+ (($ $ktrunc) live-set)
+ (($ $kif) live-set)))
+
+ (define (visit-term term label live-set)
+ (match term
+ (($ $letk conts body)
+ (let ((live-set (visit-term body label live-set)))
+ (for-each (match-lambda
+ (($ $cont k src cont)
+ (visit-cont cont k live-set)))
+ conts))
+ live-set)
+
+ (($ $continue k exp)
+ (visit-exp exp label k live-set))))
+
+ (define (visit-exp exp label k live-set)
+ (define (use sym live-set)
+ (if (and (lookup-slot sym allocation) (dead-after-use? sym k dfg))
+ (dead sym k live-set)
+ live-set))
+
+ (match exp
+ (($ $var sym)
+ (use sym live-set))
+
+ (($ $call proc args)
+ (match (lookup-cont k (dfg-cont-table dfg))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length args))))
+ (set! nlocals (max nlocals tail-nlocals))
+ (parallel-move! label
+ (map (cut lookup-slot <> allocation)
+ (cons proc args))
+ live-set (fold use live-set (cons proc args))
+ (iota tail-nlocals))))
+ (($ $ktrunc arity kargs)
+ (let* ((live-set
+ (fold use
+ (use proc
+ (allocate-frame! label (length args) live-set))
+ args))
+ (proc-slot (lookup-call-proc-slot label allocation))
+ (dst-syms (lookup-bound-syms kargs dfg))
+ (nvals (length dst-syms))
+ (src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
+ (live-set* (fold (cut allocate! <> kargs <> <>)
+ live-set dst-syms src-slots))
+ (dst-slots (map (cut lookup-slot <> allocation)
+ dst-syms)))
+ (parallel-move! label src-slots live-set live-set* dst-slots)))
+ (else
+ (fold use
+ (use proc (allocate-frame! label (length args) live-set))
+ args))))
+
+ (($ $primcall name args)
+ (fold use live-set args))
+
+ (($ $values args)
+ (let ((live-set* (fold use live-set args)))
+ (define (compute-dst-slots)
+ (match (lookup-cont k (dfg-cont-table dfg))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length args))))
+ (set! nlocals (max nlocals tail-nlocals))
+ (cdr (iota tail-nlocals))))
+ (_
+ (let* ((src-slots (map (cut lookup-slot <> allocation) args))
+ (dst-syms (lookup-bound-syms k dfg))
+ (dst-live-set (fold (cut allocate! <> k <> <>)
+ live-set* dst-syms src-slots)))
+ (map (cut lookup-slot <> allocation) dst-syms)))))
+
+ (parallel-move! label
+ (map (cut lookup-slot <> allocation) args)
+ live-set live-set*
+ (compute-dst-slots))))
+
+ (($ $prompt escape? tag handler)
+ (use tag live-set))
+
+ (_ live-set)))
+
+ (match clause
+ (($ $cont k _ body)
+ (visit-cont body k live-set)
+ (hashq-set! allocation k nlocals))))
+
+ (match fun
+ (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
+ (let ((live-set (add-live-variable self 0 (empty-live-set))))
+ (hashq-set! allocation self (make-allocation k 0 '() #f #f))
+ (for-each (cut visit-clause <> live-set) clauses)
+ allocation))))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
index 38dc54d..493b547 100644
--- a/module/language/cps/spec.scm
+++ b/module/language/cps/spec.scm
@@ -21,6 +21,7 @@
(define-module (language cps spec)
#:use-module (system base language)
#:use-module (language cps)
+ #:use-module (language cps compile-rtl)
#:export (cps))
(define* (write-cps exp #:optional (port (current-output-port)))
@@ -31,6 +32,6 @@
#:reader (lambda (port env) (read port))
#:printer write-cps
#:parser parse-cps
- #:compilers '()
+ #:compilers `((rtl . ,compile-rtl))
#:for-humans? #f
)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index fad64b7..c4e4d1f 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -115,6 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/receive.test \
tests/regexp.test \
tests/rtl.test \
+ tests/rtl-compilation.test \
tests/session.test \
tests/signals.test \
tests/srcprop.test \
diff --git a/test-suite/tests/rtl-compilation.test
b/test-suite/tests/rtl-compilation.test
new file mode 100644
index 0000000..cf00a4f
--- /dev/null
+++ b/test-suite/tests/rtl-compilation.test
@@ -0,0 +1,200 @@
+;;;; rtl-compilation.test --- test suite for compiling via rtl -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-suite rtl-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system vm objcode))
+
+(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module)))
+ (load-thunk-from-memory
+ (compile exp #:env env #:to 'rtl
+ #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-rtl exp #:key (env (make-fresh-user-module)))
+ (let ((thunk (compile-via-rtl exp #:env env)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (thunk)))))
+
+(with-test-prefix "tail context"
+ (pass-if-equal 1
+ (run-rtl '(let ((x 1)) x)))
+
+ (pass-if-equal 1
+ (run-rtl 1))
+
+ (pass-if-equal (if #f #f)
+ (run-rtl '(if #f #f)))
+
+ (pass-if-equal "top-level define"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (let ((result (run-rtl '(define v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level set!"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'v #f)
+ (let ((result (run-rtl '(set! v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level apply [single value]"
+ 8
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'args '(2 3))
+ (run-rtl '(apply expt args) #:env mod)))
+
+ (pass-if-equal "top-level apply [zero values]"
+ '()
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda () (values)))
+ (module-define! mod 'args '())
+ (call-with-values
+ (lambda () (run-rtl '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "top-level apply [two values]"
+ '(1 2)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda (n d) (floor/ n d)))
+ (module-define! mod 'args '(5 3))
+ (call-with-values
+ (lambda () (run-rtl '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "call-with-values"
+ '(1 2 3)
+ ((run-rtl '(lambda (n d)
+ (call-with-values (lambda () (floor/ n d))
+ (lambda (q r) (list q r (+ q r))))))
+ 5 3))
+
+ (pass-if-equal cons
+ (run-rtl 'cons))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda () 1))))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda (x) 1)) 2))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda (x) x)) 1))
+
+ (pass-if-equal 6
+ ((((run-rtl '(lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))) 1) 2) 3))
+
+ (pass-if-equal 1
+ (run-rtl '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-rtl '(cons 1 2)))
+
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-rtl '(values 1 2))) list))
+
+ (pass-if-equal 28
+ ((run-rtl '(lambda (x y z rest) (apply + x y z rest)))
+ 2 3 5 '(7 11)))
+
+ ;; prompts
+ )
+
+(with-test-prefix "value context"
+ 1
+ )
+
+(with-test-prefix "drop context"
+ 1
+ )
+
+(with-test-prefix "test context"
+ 1
+ )
+
+(with-test-prefix "values context"
+ (pass-if-equal '(3 . 1)
+ (run-rtl
+ '(let ((rat (lambda (n d)
+ (call-with-values
+ (lambda () (floor/ n d))
+ (lambda (q r)
+ (cons q r))))))
+ (rat 10 3)))))
+
+(with-test-prefix "contification"
+ (pass-if ((run-rtl '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3 4)))
+
+ (pass-if (not ((run-rtl '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3)))))
+
+(with-test-prefix "case-lambda"
+ (pass-if-equal "simple"
+ '(0 3 9 28)
+ (let ((proc (run-rtl '(case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z . rest) (apply + x y z rest))))))
+ (map (lambda (args) (apply proc args))
+ '(() (3) (2 7) (2 3 5 7 11)))))
+
+ (pass-if-exception "no match"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda ((x) x) ((x y) (+ x y))))
+ 1 2 3))
+
+ (pass-if-exception "zero clauses called with no args"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda))))
+
+ (pass-if-exception "zero clauses called with args"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+ (pass-if-equal "sequences" '(3 4 5)
+ (let* ((pair (cons 1 2))
+ (result ((run-rtl '(lambda (pair)
+ (set-car! pair 3)
+ (set-cdr! pair 4)
+ 5))
+ pair)))
+ (list (car pair)
+ (cdr pair)
+ result)))
+
+ (pass-if-equal "mutable lexicals" 2
+ (run-rtl '(let ((n 1)) (set! n 2) n))))
--
1.8.3.2
- Re: [PATCH 1/9] Add CPS language, (continued)
- [PATCH 3/9] Add closure conversion, Andy Wingo, 2013/08/29
- [PATCH 7/9] Add pass to reify primcalls without corresponding VM ops, Andy Wingo, 2013/08/29
- [PATCH 8/9] Add CPS -> RTL compiler,
Andy Wingo <=
- [PATCH 9/9] Add contification pass, Andy Wingo, 2013/08/29
- Re: CPS language and Tree-IL->CPS->RTL compiler, Ludovic Courtès, 2013/08/29
- Re: CPS language and Tree-IL->CPS->RTL compiler, Noah Lavine, 2013/08/29