[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-182-gb1c7
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-182-gb1c738a |
|
Date: |
Thu, 15 Aug 2013 17:57:47 +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=b1c738acc774d5125a8f63dcf5bf331eb14a1fcc
The branch, wip-cps-bis has been updated
via b1c738acc774d5125a8f63dcf5bf331eb14a1fcc (commit)
via df16f8d1a66b810e02b906cc97c6c70ab04b8e30 (commit)
via 2c5391283bc5ed3d0344badf70012ac867009345 (commit)
via 9f3bc3b3eae4f51b432f25f1f4ba40a172197980 (commit)
via 8f1a0ef3fe051658eaa3fd8714add48de5dc3c9e (commit)
from 8240e5fd13b3288ff40c67f9b4f0f396678e18ec (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 b1c738acc774d5125a8f63dcf5bf331eb14a1fcc
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 19:57:14 2013 +0200
$fun has list of entries; rewrite compile-cps to use builder macros
* module/language/cps.scm: Change $fun to have a list of entries. A
$kentry no longer knows about its "alternate".
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-rtl.scm:
* module/language/cps/dfg.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm: Adapt to change.
* module/language/tree-il/compile-cps.scm: Rewrite to use new "builder"
macros.
commit df16f8d1a66b810e02b906cc97c6c70ab04b8e30
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 14:09:52 2013 +0200
Add RTL compiler test.
* test-suite/tests/rtl-compilation.test: New test.
commit 2c5391283bc5ed3d0344badf70012ac867009345
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 14:09:20 2013 +0200
Add reify-primitives pass
* module/language/cps/reify-primitives.scm: New module, implements a
pass to reify primitives that don't have corresponding VM ops.
* module/language/cps/compile-rtl.scm (compile-rtl): Run
reify-primitives at the end of transformation.
* module/Makefile.am: Update.
commit 9f3bc3b3eae4f51b432f25f1f4ba40a172197980
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 14:09:20 2013 +0200
Add (language cps primitives)
* module/Makefile.am:
* module/language/cps/primitives.scm: New module, exports predicates
about primitives known to CPS.
* module/language/tree-il/arities.scm:
* module/language/tree-il/compile-cps.scm: Use the facilities from
(language cps primitives).
commit 8f1a0ef3fe051658eaa3fd8714add48de5dc3c9e
Author: Andy Wingo <address@hidden>
Date: Thu Aug 15 11:48:22 2013 +0200
Add rtl-instruction-arity to (language rtl).
* module/language/rtl.scm (rtl-instruction-arity): New interface,
imported from (language cps primitives).
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 2 +
module/language/cps.scm | 24 +-
module/language/cps/arities.scm | 128 +-----
module/language/cps/closure-conversion.scm | 65 ++--
module/language/cps/compile-rtl.scm | 50 ++-
module/language/cps/dfg.scm | 4 +-
module/language/cps/primitives.scm | 96 ++++
module/language/cps/reify-primitives.scm | 172 ++++++++
module/language/cps/slot-allocation.scm | 5 +-
module/language/cps/verify.scm | 77 ++--
module/language/rtl.scm | 71 +++-
module/language/tree-il/compile-cps.scm | 649 ++++++++++++++--------------
test-suite/Makefile.am | 1 +
test-suite/tests/rtl-compilation.test | 81 ++++
14 files changed, 880 insertions(+), 545 deletions(-)
create mode 100644 module/language/cps/primitives.scm
create mode 100644 module/language/cps/reify-primitives.scm
create mode 100644 test-suite/tests/rtl-compilation.test
diff --git a/module/Makefile.am b/module/Makefile.am
index dcd311c..5a0ff69 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -124,6 +124,8 @@ CPS_LANG_SOURCES =
\
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.scm b/module/language/cps.scm
index e0e2e8e..29c688a 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -108,7 +108,7 @@
(define-cps-type $kif kt kf)
(define-cps-type $ktrunc arity k)
(define-cps-type $kargs names syms body)
-(define-cps-type $kentry arity cont alternate)
+(define-cps-type $kentry arity cont)
;; Calls.
(define-cps-type $continue k exp)
@@ -116,7 +116,7 @@
(define-cps-type $void)
(define-cps-type $const val)
(define-cps-type $prim name)
-(define-cps-type $fun meta self free body)
+(define-cps-type $fun meta self free entries)
(define-cps-type $letrec names syms funs body)
(define-cps-type $call proc args)
(define-cps-type $primcall name args)
@@ -144,12 +144,9 @@
(make-$ktrunc (make-$arity req '() rest '() #f) k))
(('kargs names syms body)
(make-$kargs names syms (parse-cps body)))
- (('kentry (req opt rest kw allow-other-keys?) body . tail)
+ (('kentry (req opt rest kw allow-other-keys?) body)
(make-$kentry (make-$arity req opt rest kw allow-other-keys?)
- (parse-cps body)
- (match tail
- ((alternate) (parse-cps alternate))
- (() #f))))
+ (parse-cps body)))
(('kseq body)
(make-$kargs '() '() (parse-cps body)))
@@ -164,8 +161,8 @@
(make-$const exp))
(('prim name)
(make-$prim name))
- (('fun meta self free body)
- (make-$fun meta self free (parse-cps body)))
+ (('fun meta self free entries)
+ (make-$fun meta self free (map parse-cps entries)))
(('letrec ((name sym fun) ...) body)
(make-$letrec name sym (map parse-cps fun) (parse-cps body)))
(('call proc arg ...)
@@ -197,10 +194,9 @@
`(kseq ,(unparse-cps body)))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kentry ($ $arity req opt rest kw allow-other-keys?) body alternate)
+ (($ $kentry ($ $arity req opt rest kw allow-other-keys?) body)
`(kentry (,req ,opt ,rest ,kw ,allow-other-keys?)
- ,(unparse-cps body)
- ,@(if alternate (list (unparse-cps alternate)) '())))
+ ,(unparse-cps body)))
;; Calls.
(($ $continue k exp)
@@ -213,8 +209,8 @@
`(const ,val))
(($ $prim name)
`(prim ,name))
- (($ $fun meta self free body)
- `(fun ,meta ,self ,free ,(unparse-cps body)))
+ (($ $fun meta self free entries)
+ `(fun ,meta ,self ,free ,(map unparse-cps entries)))
(($ $letrec names syms funs body)
`(letrec ,(map (lambda (name sym fun)
(list name sym (unparse-cps fun)))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 4c3cac1..3c52268 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -26,8 +26,8 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-26)
#:use-module (language cps)
- #:use-module (system vm instruction)
- #:export (fix-arities *rtl-instruction-aliases*))
+ #:use-module (language cps primitives)
+ #:export (fix-arities))
(define (make-$let1k cont body)
(make-$letk (list cont) body))
@@ -38,8 +38,11 @@
(define (fold-conts proc seed term)
(match term
- (($ $fun meta self free body)
- (fold-conts proc seed body))
+ (($ $fun meta self free entries)
+ (fold (lambda (exp seed)
+ (fold-conts proc seed exp))
+ seed
+ entries))
(($ $letrec names syms funs body)
(fold-conts proc
@@ -60,11 +63,8 @@
(($ $cont src sym ($ $kargs names syms body))
(fold-conts proc (proc term seed) body))
- (($ $cont src sym ($ $kentry arity body alternate))
- (let ((seed (fold-conts proc (proc term seed) body)))
- (if alternate
- (fold-conts proc seed alternate)
- seed)))
+ (($ $cont src sym ($ $kentry arity body))
+ (fold-conts proc (proc term seed) body))
(($ $cont)
(proc term seed))
@@ -83,105 +83,6 @@
(($ $cont _ (? (cut eq? <> k))) cont)
(else (lp conts))))))))
-(define (compute-primcall-arity name args)
- (define (first-word-arity word)
- (case word
- ((U8_X24) 1)
- ((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) 2)
- ((X8_U12_U12) 3)
- ((X8_L24) 2)
- ((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 *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 *other-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-primcall-arities)
- (let ((table (make-hash-table)))
- (for-each
- (match-lambda
- ;; Put special cases here.
- ((name op '! . args)
- (hashq-set! table name
- (cons 0 (compute-primcall-arity name args))))
- ((name op '<- . args)
- (hashq-set! table name
- (cons 1 (1- (compute-primcall-arity name args))))))
- (rtl-instruction-list))
- (for-each (match-lambda
- ((name . opname)
- (hashq-set! table name (hashq-ref table opname))))
- *rtl-instruction-aliases*)
- (for-each (match-lambda
- ((name . arity)
- (hashq-set! table name arity)))
- *macro-instruction-arities*)
- (for-each (match-lambda
- ((name . arity)
- (hashq-set! table name arity)))
- *other-primcall-arities*)
- table))
-
-(define *primcall-arities* (delay (compute-primcall-arities)))
-
-(define (primcall-arity name)
- (or (hashq-ref (force *primcall-arities*) name)
- (error "Primcall of unknown arity" name)))
-
(define (fix-arities term)
(let ((conts (fold-conts cons '() term)))
(define (adapt nvals k proc)
@@ -242,13 +143,12 @@
(make-$letk (map lp conts) (lp body)))
(($ $cont src sym ($ $kargs names syms body))
(make-$cont src sym (make-$kargs names syms (lp body))))
- (($ $cont src sym ($ $kentry arity body alternate))
- (make-$cont src sym (make-$kentry arity (lp body)
- (and alternate (lp alternate)))))
+ (($ $cont src sym ($ $kentry arity body))
+ (make-$cont src sym (make-$kentry arity (lp body))))
(($ $cont)
term)
- (($ $fun meta self free body)
- (make-$fun meta self free (lp body)))
+ (($ $fun meta self free entries)
+ (make-$fun meta self free (map lp entries)))
(($ $letrec names syms funs body)
(make-$letrec names syms (map lp funs) (lp body)))
(($ $continue k exp)
@@ -273,7 +173,7 @@
;; Primcalls to return are in tail position.
(make-$continue 'ktail exp))
(($ $primcall name args)
- (match (primcall-arity name)
+ (match (prim-arity name)
((out . in)
(adapt
out
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 24a5b4f..7b33dd7 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -101,33 +101,37 @@ continue with @var{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)
- (let lp ((conts conts) (conts* '()) (free '()))
- (match conts
- (()
- (receive (body free*) (cc body self bound)
- (values (make-$letk (reverse conts*) body)
- (union free free*))))
- ((cont . conts)
- (receive (cont* free*) (cc cont self bound)
- (lp conts (cons cont* conts*) (union free free*)))))))
+ (receive (conts free) (cc* conts self bound)
+ (receive (body free*) (cc body self bound)
+ (values (make-$letk conts body)
+ (union free free*)))))
(($ $cont src sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
(values (make-$cont src sym (make-$kargs names syms body))
free)))
- (($ $cont src sym ($ $kentry arity body alternate))
+ (($ $cont src sym ($ $kentry arity body))
(receive (body free) (cc body self bound)
- (receive (alternate free*)
- (if alternate (cc alternate self bound) (values #f '()))
- (values (make-$cont src sym (make-$kentry arity body alternate))
- (union free free*)))))
+ (values (make-$cont src sym (make-$kentry arity body))
+ free)))
(($ $cont)
;; Other kinds of continuations don't bind values and don't have
@@ -144,14 +148,14 @@ convert functions to flat closures."
(free free))
(match in
(() (values (bindings body) free))
- (((name sym ($ $fun meta self () fun-body)) . in)
- (receive (fun-body fun-free) (cc fun-body self (list self))
+ (((name sym ($ $fun meta self () entries)) . in)
+ (receive (entries fun-free) (cc* entries self (list self))
(lp in
(lambda (body)
(let ((k (gensym "k")))
(make-$let1v
#f k name sym (bindings body)
- (make-$continue k (make-$fun meta self fun-free
fun-body)))))
+ (make-$continue k (make-$fun meta self fun-free
entries)))))
(init-closure #f sym fun-free body)
(union free (difference fun-free bound))))))))))
@@ -167,11 +171,11 @@ convert functions to flat closures."
($ $prim)))
(values exp '()))
- (($ $continue k ($ $fun meta self () body))
- (receive (body free) (cc body self (list self))
+ (($ $continue k ($ $fun meta self () entries))
+ (receive (entries free) (cc* entries self (list self))
(match free
(()
- (values (make-$continue k (make-$fun meta self free body))
+ (values (make-$continue k (make-$fun meta self free entries))
free))
(else
(values
@@ -181,7 +185,7 @@ convert functions to flat closures."
#f kinit v v
(init-closure #f v free
(make-$continue k (make-$var v)))
- (make-$continue kinit (make-$fun meta self free body))))
+ (make-$continue kinit (make-$fun meta self free entries))))
(difference free bound))))))
(($ $continue k ($ $call proc args))
@@ -222,10 +226,8 @@ convert functions to flat closures."
(make-$letk (map lp conts) (lp body)))
(($ $cont src sym ($ $kargs names syms body))
(make-$cont src sym (make-$kargs names syms (lp body))))
- (($ $cont src sym ($ $kentry arity body alternate))
- (make-$cont src sym (make-$kentry arity (lp body)
- (and alternate
- (lp alternate)))))
+ (($ $cont src sym ($ $kentry arity body))
+ (make-$cont src sym (make-$kentry arity (lp body))))
;; Other kinds of continuations don't
;; bind values and don't have bodies.
(($ $cont) exp)
@@ -253,8 +255,9 @@ convert functions to flat closures."
(($ $continue k (or ($ $var) ($ $void) ($ $const) ($ $prim)
($ $call) ($ $values) ($ $prompt) ($ $primcall)))
exp)
- (($ $continue k ($ $fun meta self free body))
- (make-$continue k (make-$fun meta self free (lpfree body free))))
+ (($ $continue k ($ $fun meta self free entries))
+ (make-$continue k (make-$fun meta self free
+ (map (cut lpfree <> free) entries))))
(($ $values args) exp)
(_ ((error "convert-to-indices: unhandled case")))))))
@@ -262,8 +265,8 @@ convert functions to flat closures."
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
(match exp
- (($ $fun meta self () body)
- (receive (body free) (cc body #f '())
+ (($ $fun meta self () entries)
+ (receive (entries free) (cc* entries #f '())
(unless (null? free)
- (error "Expected no free vars in toplevel thunk" exp))
- (make-$fun meta self '() (convert-to-indices body))))))
+ (error "Expected no free vars in toplevel thunk" exp entries free))
+ (make-$fun meta self '() (map convert-to-indices entries))))))
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 0ef3914..8f2c7ab 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -27,6 +27,8 @@
#:use-module (language cps)
#:use-module (language cps arities)
#:use-module (language cps closure-conversion)
+ #:use-module (language cps primitives)
+ #:use-module (language cps reify-primitives)
#:use-module (language cps slot-allocation)
#:export (compile-rtl))
@@ -69,9 +71,9 @@
(($ $continue _ exp)
(visit-funs proc exp))
- (($ $fun meta self free body)
+ (($ $fun meta self free entries)
(proc exp)
- (visit-funs proc body))
+ (for-each (lambda (entry) (visit-funs proc entry)) entries))
(($ $letk conts body)
(visit-funs proc body)
@@ -80,10 +82,8 @@
(($ $cont src sym ($ $kargs names syms body))
(visit-funs proc body))
- (($ $cont src sym ($ $kentry arity body alternate))
- (visit-funs proc body)
- (when alternate
- (visit-funs proc alternate)))
+ (($ $cont src sym ($ $kentry arity body))
+ (visit-funs proc body))
(_ (values))))
@@ -168,9 +168,9 @@
(($ $const exp)
(when dst
(emit `(load-constant ,dst ,exp))))
- (($ $fun meta self () body)
+ (($ $fun meta self () entries)
(emit `(load-static-procedure ,dst ,self)))
- (($ $fun meta self free body)
+ (($ $fun meta self free entries)
(emit `(make-closure ,dst ,self ,(length free))))
(($ $call proc args)
(let ((proc-slot (lookup-call-proc-slot label slots))
@@ -199,9 +199,8 @@
(($ $primcall 'free-ref (closure idx))
(emit `(free-ref ,dst ,(slot closure) ,(constant idx))))
(($ $primcall name args)
- (let ((name (or (assq-ref *rtl-instruction-aliases* name)
- name)))
- (emit `(,name ,dst ,@(map slot args)))))
+ (let ((inst (prim-rtl-instruction name)))
+ (emit `(,inst ,dst ,@(map slot args)))))
(($ $values (arg))
(or (maybe-load-constant (slot dst) arg)
(maybe-mov dst (slot arg))))
@@ -332,14 +331,12 @@
(define (emit asm)
(set! rtl (cons asm rtl)))
- (define (emit-fun-body self body)
+ (define (emit-fun-entry self body alternate)
(call-with-values (lambda () (allocate-slots self body))
(lambda (slots nlocals)
(match body
(($ $cont src k
- ($ $kentry ($ $arity req opt rest kw allow-other-keys?)
- body
- alternate))
+ ($ $kentry ($ $arity req opt rest kw allow-other-keys?) body))
(let ((kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym slots))))
@@ -348,19 +345,25 @@
(emit `(begin-kw-arity ,req ,opt ,rest
,kw-indices ,allow-other-keys?
,nlocals
- ,(match alternate
- (($ $cont _ k) k)
- (#f #f))))
+ ,alternate))
(for-each emit (emit-rtl-sequence body slots nlocals))
- (emit `(end-arity))
- (when alternate
- (emit-fun-body self alternate))))))))
+ (emit `(end-arity))))))))
+
+ (define (emit-fun-entries self entries)
+ (match entries
+ ((entry . entries)
+ (let ((alternate (match entries
+ (($cont _ k) k)
+ (() #f))))
+ (emit-fun-entry self entry alternate)
+ (when alternate
+ (emit-fun-entries self entries))))))
(match f
;; FIXME: We shouldn't use SELF as a label.
- (($ $fun meta self free body)
+ (($ $fun meta self free entries)
(emit `(begin-program ,self ,(or meta '())))
- (emit-fun-body self body)
+ (emit-fun-entries self entries)
(emit `(end-program))
(reverse rtl)))))
@@ -368,6 +371,7 @@
(let* ((exp (fix-arities exp))
(exp (optimize exp opts))
(exp (convert-closures exp))
+ (exp (reify-primitives exp))
(rtl '()))
(visit-funs (lambda (fun)
(set! rtl (cons (compile-fun fun) rtl)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 6a86f97..4c51aba 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -97,7 +97,7 @@
;; Treat the entry continuation as its own parent, and as a hack
;; declare "ktail" as being a child of the entry.
- (($ $cont src k ($ $kentry arity body alternate))
+ (($ $cont src k ($ $kentry arity body))
(when exp-k
(error "$kentry not at top level?"))
(add-def! k k)
@@ -105,8 +105,6 @@
(hashq-set! uplinks k (make-uplink #f 0))
(add-def! 'ktail k)
(link-parent! 'ktail k)
- ;; The alternate clause, if present, should be analyzed
- ;; separately.
(visit body k))
(($ $cont src k cont)
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..378cb89
--- /dev/null
+++ b/module/language/cps/reify-primitives.scm
@@ -0,0 +1,172 @@
+;;; 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 (ice-9 vlist)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (language cps)
+ #:use-module (language cps primitives)
+ #:use-module (language rtl)
+ #:export (reify-primitives))
+
+;; FIXME: Some of these common utilities should be factored elsewhere,
+;; perhaps (language cps).
+
+(define (make-$let1k cont body)
+ (make-$letk (list cont) body))
+
+(define (make-$let1v src k name sym cont-body body)
+ (make-$let1k (make-$cont src k (make-$kargs (list name) (list sym)
cont-body))
+ body))
+
+(define (make-let src val-proc body-proc)
+ (let ((k (gensym "k")) (sym (gensym "v")))
+ (make-$let1v src k 'tmp sym (body-proc sym) (val-proc k))))
+
+(define (make-$let1c src name sym val cont-body)
+ (let ((k (gensym "kconst")))
+ (make-$let1v src k name sym cont-body (make-$continue k (make-$const
val)))))
+
+(define (fold-conts proc seed term)
+ (match term
+ (($ $fun meta self free entries)
+ (fold (lambda (exp seed)
+ (fold-conts proc seed exp))
+ seed
+ entries))
+
+ (($ $letrec names syms funs body)
+ (fold-conts proc
+ (fold (lambda (exp seed)
+ (fold-conts proc seed exp))
+ seed
+ funs)
+ body))
+
+ (($ $letk conts body)
+ (fold-conts proc
+ (fold (lambda (exp seed)
+ (fold-conts proc seed exp))
+ seed
+ conts)
+ body))
+
+ (($ $cont src sym ($ $kargs names syms body))
+ (fold-conts proc (proc term seed) body))
+
+ (($ $cont src sym ($ $kentry arity body))
+ (fold-conts proc (proc term seed) body))
+
+ (($ $cont)
+ (proc term seed))
+
+ (($ $continue k exp)
+ (match exp
+ (($ $fun) (fold-conts proc seed exp))
+ (_ seed)))))
+
+(define (lookup-cont table k)
+ (cond
+ ((vhash-assq k table) => cdr)
+ (else (error "unknown cont" k))))
+
+(define (build-cont-table term)
+ (fold-conts (lambda (cont table)
+ (match cont
+ (($ $cont src k cont)
+ (vhash-consq k cont table))))
+ vlist-null
+ term))
+
+(define (module-box src module name public? bound? val-proc)
+ (let ((module-sym (gensym "module"))
+ (name-sym (gensym "name"))
+ (public?-sym (gensym "public?"))
+ (bound?-sym (gensym "bound?")))
+ (make-$let1c
+ src 'module module-sym module
+ (make-$let1c
+ src 'name name-sym name
+ (make-$let1c
+ src 'public? public?-sym public?
+ (make-$let1c
+ src 'bound? bound?-sym bound?
+ (make-let
+ src
+ (lambda (k)
+ (make-$continue k (make-$primcall
+ 'cached-module-box
+ (list module-sym name-sym public?-sym
bound?-sym))))
+ val-proc)))))))
+
+(define (primitive-ref name k)
+ (module-box #f '(guile) name #f #t
+ (lambda (box)
+ (make-$continue k (make-$primcall 'box-ref (list box))))))
+
+(define (reify-primitives fun)
+ (let ((conts (build-cont-table fun)))
+ (define (visit-fun term)
+ (match term
+ (($ $fun meta self free entries)
+ (make-$fun meta self free (map visit-entry entries)))))
+ (define (visit-entry term)
+ (match term
+ (($ $cont src sym ($ $kentry arity body))
+ (make-$cont src sym
+ (make-$kentry arity (visit-cont body))))))
+ (define (visit-cont term)
+ (match term
+ (($ $cont src sym ($ $kargs names syms body))
+ (make-$cont src sym (make-$kargs names syms (visit-term body))))
+ (_ term)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (make-$letk (map visit-cont conts) (visit-term body)))
+ (($ $continue k exp)
+ (match exp
+ (($ $prim name)
+ (match (lookup-cont conts k)
+ (($ $kargs (_)) (primitive-ref name k))
+ (_ (make-$continue k (make-$void)))))
+ (($ $fun)
+ (make-$continue k (visit-fun exp)))
+ (($ $primcall name args)
+ (cond
+ ((or (prim-rtl-instruction name) (branching-primitive? name))
+ ;; Assume arities are correct.
+ term)
+ (else
+ (make-let #f
+ (lambda (k)
+ (primitive-ref name k))
+ (lambda (v)
+ (make-$continue k (make-$call v args)))))))
+ (_ term)))))
+
+ (visit-fun fun)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 34311e9..7aa1122 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -212,7 +212,7 @@ are comparable with eqv?. A tmp slot may be used."
(nlocals 0)
(nargs (match exp
(($ $cont _ _
- ($ $kentry _ ($ $cont _ _ ($ $kargs names syms)) _))
+ ($ $kentry _ ($ $cont _ _ ($ $kargs names syms))))
(length syms))))
(visited (make-hash-table))
(allocation (make-hash-table)))
@@ -297,8 +297,7 @@ are comparable with eqv?. A tmp slot may be used."
(hashq-set! visited k #t)
(visit cont k live-set))
- (($ $kentry arity body alternate)
- ;; Alternate clauses, if any, should be allocated separately.
+ (($ $kentry arity body)
(visit body exp-k (allocate! self exp-k 0 live-set)))
(($ $kargs names syms body)
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 6ddffd3..eed74dd 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -92,7 +92,7 @@
#t)
(($ $prim name)
(unless (symbol? name) (error "name should be a symbol" exp)))
- (($ $fun meta self free body)
+ (($ $fun meta self free entries)
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(unless (symbol? self)
@@ -101,43 +101,41 @@
(error "free should be list of symbols" exp))
(unless (symbol? k)
(error "entry should be symbol" k))
- (let lp ((body body))
- (match body
- (#f #t)
- (($ $cont src* k*
- ($ $kentry arity ($ $cont src k ($ $kargs names syms body))
- alternate))
- (check-src src*)
- (check-src src)
- (match arity
- (($ $arity ((? symbol?) ...) ((? symbol?) ...) (or #f (?
symbol?))
- (((? keyword?)
- (? symbol?)
- (and (? symbol?) (? (cut memq <> syms))))
- ...)
- (or #f #t))
- #t)
- (else (error "bad arity" arity)))
- (unless (and (list? names) (and-map symbol? names))
- (error "letrec names not symbols" exp))
- (unless (and (list? syms) (and-map symbol? syms))
- (error "letrec syms not symbols" exp))
- (unless (match arity
- (($ $arity req opt rest kw allow-other-keys?)
- (= (length syms)
- (length names)
- (+ (length req)
- (length opt)
- (if rest 1 0)
- ;; FIXME: technically possible for kw syms to
- ;; alias other syms
- (length kw)))))
- (error "unexpected fun-case syms" exp))
- ;; The continuation environment is null, because we don't turn
- ;; captured continuations into closures.
- (visit body (add-env (list k* k) '())
- (add-env (cons self syms) v-env))
- (lp alternate)))))
+ (for-each
+ (match-lambda
+ (($ $cont src* k*
+ ($ $kentry arity ($ $cont src k ($ $kargs names syms body))))
+ (check-src src*)
+ (check-src src)
+ (match arity
+ (($ $arity ((? symbol?) ...) ((? symbol?) ...) (or #f (?
symbol?))
+ (((? keyword?)
+ (? symbol?)
+ (and (? symbol?) (? (cut memq <> syms))))
+ ...)
+ (or #f #t))
+ #t)
+ (else (error "bad arity" arity)))
+ (unless (and (list? names) (and-map symbol? names))
+ (error "letrec names not symbols" exp))
+ (unless (and (list? syms) (and-map symbol? syms))
+ (error "letrec syms not symbols" exp))
+ (unless (match arity
+ (($ $arity req opt rest kw allow-other-keys?)
+ (= (length syms)
+ (length names)
+ (+ (length req)
+ (length opt)
+ (if rest 1 0)
+ ;; FIXME: technically possible for kw syms to
+ ;; alias other syms
+ (length kw)))))
+ (error "unexpected fun-case syms" exp))
+ ;; The continuation environment is null, because we don't turn
+ ;; captured continuations into closures.
+ (visit body (add-env (list k* k) '())
+ (add-env (cons self syms) v-env))))
+ entries))
(($ $letrec names syms funs body)
(unless (and (list? names) (and-map symbol? names))
(error "letrec names not symbols" exp))
@@ -150,8 +148,7 @@
(error "letrec syms, names, and funs not same length" exp))
(let ((v-env (add-env syms v-env)))
(for-each (cut visit <> k-env v-env) funs)
- (visit body k-env v-env)))
- (($ $call proc args)
+ (visit body k-env v-env)))(($ $call proc args)
(check-var proc v-env)
(for-each (cut check-var <> v-env) args))
(($ $primcall name args)
diff --git a/module/language/rtl.scm b/module/language/rtl.scm
index aec5030..8438058 100644
--- a/module/language/rtl.scm
+++ b/module/language/rtl.scm
@@ -19,5 +19,74 @@
;;; 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))
+ #: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) 1)
+ ((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) 2)
+ ((X8_U12_U12) 3)
+ ((X8_L24) 2)
+ ((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/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index ae6a23f..d77b9d4 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -27,6 +27,7 @@
#: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)
@@ -46,29 +47,97 @@
tree-il-fold))
#:export (compile-cps))
-;; Helpers.
-(define-inlinable (make-$let1k cont body)
- (make-$letk (list cont) body))
-(define-inlinable (make-$let1v src k name sym cont-body body)
- (make-$let1k (make-$cont src k (make-$kargs (list name) (list sym)
cont-body))
- body))
-(define-inlinable (make-$let1c src name sym val cont-body)
- (let ((k (gensym "kconst")))
- (make-$let1v src k name sym cont-body (make-$continue k (make-$const
val)))))
-(define-inlinable (make-$letk* conts body)
- (match conts
- (() body)
- ((cont . conts)
- (make-$let1k cont (make-$letk* conts body)))))
-(define-inlinable (make-let src val-proc body-proc)
- (let ((k (gensym "k")) (sym (gensym "v")))
- (make-$let1v src k 'tmp sym (body-proc sym) (val-proc k))))
-
-(define *branching-primitives*
- '(null? nil? pair? struct? char? eq? eqv? equal? < <= = >= >))
-
-(define (branching-primitive? name)
- (memq name *branching-primitives*))
+;; (put 'build-cps 'scheme-indent-function 0)
+;; (put 'build-cps* 'scheme-indent-function 1)
+;; (put '$letk 'scheme-indent-function 1)
+;; (put '$letk* 'scheme-indent-function 1)
+;; (put '$letconst 'scheme-indent-function 1)
+;; (put '$continue 'scheme-indent-function 1)
+;; (put '$kargs 'scheme-indent-function 2)
+;; (put 'convert-arg 'scheme-indent-function 1)
+;; (put 'convert-args 'scheme-indent-function 1)
+
+(define-syntax build-cont
+ (syntax-rules (unquote $kif $ktrunc $kargs)
+ ((_ (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 body)))
+ ((_ ($kargs names syms body))
+ (make-$kargs names syms (build-cps body)))))
+
+(define-syntax build-cont-decl
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (k src cont)) (make-$cont src k (build-cont cont)))))
+
+(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-fun-entry
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ ($kentry k src arity cont-decl))
+ (make-$cont src k (make-$kentry (build-arity arity)
+ (build-cont-decl cont-decl))))))
+
+(define-syntax build-fun
+ (syntax-rules (unquote)
+ ((_ ($fun meta self free (unquote body)))
+ (make-$fun meta self free body))
+ ((_ ($fun meta self free (entry ...)))
+ (make-$fun meta self free (list (build-fun-entry entry) ...)))))
+
+(define-syntax build-call
+ (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 . args)) (build-fun ($fun . args)))
+ ((_ ($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
+ (syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($letk (cont-decl ...) body))
+ (make-$letk (list (build-cont-decl cont-decl) ...)
+ (build-cps body)))
+ ((_ ($letk* () body))
+ (build-cps body))
+ ((_ ($letk* (cont-decl cont-decls ...) body))
+ (build-cps ($letk (cont-decl) ($letk* (cont-decls ...) body))))
+ ((_ ($letconst () body))
+ (build-cps body))
+ ((_ ($letconst ((name sym val) tail ...) body))
+ (build-cps* (kconst)
+ ($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 body)))
+ ((_ ($continue k exp)) (make-$continue k (build-call exp)))))
+
+(define-syntax build-cps*
+ (syntax-rules ()
+ ((_ (sym ...) form)
+ (let ((sym (gensym (symbol->string 'sym))) ...)
+ (build-cps form)))))
;; Guile's semantics are that a toplevel lambda captures a reference on
;; the current module, and that all contained lambdas use that module to
@@ -86,62 +155,43 @@
(define current-topbox-scope (make-parameter #f))
(define (toplevel-box src name bound? val-proc)
- (let ((name-sym (gensym "name"))
- (bound?-sym (gensym "bound?")))
- (make-$let1c
- src 'name name-sym name
- (make-$let1c
- src 'bound? bound?-sym bound?
- (make-let
- src
- (lambda (k)
- (match (current-topbox-scope)
+ (build-cps* (name-sym bound?-sym kbox box)
+ ($letconst (('name name-sym name)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box))))
+ ,(match (current-topbox-scope)
(#f
- (make-$continue k (make-$primcall
- 'resolve
- (list name-sym bound?-sym))))
+ (build-cps
+ ($continue kbox
+ ($primcall 'resolve
+ (name-sym bound?-sym)))))
(scope
- (let ((scope-sym (gensym "scope")))
- (make-$let1c
- src 'scope scope-sym scope
- (make-$continue k (make-$primcall
- 'cached-toplevel-box
- (list scope-sym name-sym bound?-sym))))))))
- val-proc)))))
+ (build-cps* (scope-sym)
+ ($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 ((module-sym (gensym "module"))
- (name-sym (gensym "name"))
- (public?-sym (gensym "public?"))
- (bound?-sym (gensym "bound?")))
- (make-$let1c
- src 'module module-sym module
- (make-$let1c
- src 'name name-sym name
- (make-$let1c
- src 'public? public?-sym public?
- (make-$let1c
- src 'bound? bound?-sym bound?
- (make-let
- src
- (lambda (k)
- (make-$continue k (make-$primcall
- 'cached-module-box
- (list module-sym name-sym public?-sym
bound?-sym))))
- val-proc)))))))
+ (build-cps* (module-sym name-sym public?-sym bound?-sym kbox box)
+ ($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 ((module (gensym "module"))
- (scope-sym (gensym "scope"))
- (kmodule (gensym "kmodule")))
- (make-$let1c
- src 'scope scope-sym scope
- (make-$let1v
- src kmodule 'module module
- (make-$continue
- k
- (make-$primcall 'cache-current-module! (list module scope-sym)))
- (make-$continue kmodule (make-$primcall 'current-module '()))))))
+ (build-cps* (module scope-sym kmodule)
+ ($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
@@ -183,45 +233,32 @@
(define tc8-iflag 4)
(define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (let ((unbound-sym (gensym "unbound"))
- (ktest (gensym "ktest")))
- (make-$let1c
- src 'unbound unbound-sym (pointer->scm (make-pointer unbound-bits))
- (make-$let1k
- (make-$cont src ktest (make-$kif kt kf))
- (make-$continue ktest (make-$primcall 'eq? (list sym unbound-sym)))))))
+ (build-cps* (unbound ktest)
+ ($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 ((knext (gensym "knext"))
- (kbound (gensym "kbound"))
- (kunbound (gensym "kunbound"))
- (src (tree-il-src init)))
+ (let ((src (tree-il-src init)))
(define (maybe-box k make-body)
(if box?
- (let ((kbox (gensym "kbox"))
- (phi (gensym "phi")))
- (make-$let1k
- (make-$cont src kbox
- (make-$kargs (list name) (list phi)
- (make-$continue
- k
- (make-$primcall 'box (list phi)))))
- (make-body kbox)))
+ (build-cps* (kbox phi)
+ ($letk ((kbox src ($kargs (name) (phi)
+ ($continue k ($primcall 'box (phi))))))
+ ,(make-body kbox)))
(make-body k)))
- (make-$let1k
- (make-$cont src knext (make-$kargs (list name) (list subst-sym) body))
- (maybe-box
- knext
- (lambda (k)
- (make-$letk*
- (list
- (make-$cont src kbound
- (make-$kargs '() '() (make-$continue k (make-$var
sym))))
- (make-$cont src kunbound
- (make-$kargs '() '() (convert init k subst))))
- (unbound? src sym kunbound kbound)))))))))
+ (build-cps* (knext kbound kunbound)
+ ($letk ((knext src ($kargs (name) (subst-sym) ,body)))
+ ,(maybe-box
+ knext
+ (lambda (k)
+ (build-cps
+ ($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)
@@ -231,96 +268,128 @@
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
((box #t)
- (make-let src
- (lambda (k)
- (make-$continue k (make-$primcall 'box-ref (list box))))
- k))
+ (build-cps* (kunboxed unboxed)
+ ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+ ($continue kunboxed ($primcall 'box-ref (box))))))
((subst #f) (k subst))
(#f (k sym))))
- (else (make-let (tree-il-src exp)
- (cut convert exp <> subst)
- k))))
+ (else
+ (let ((src (tree-il-src exp)))
+ (build-cps* (karg arg)
+ ($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)))))))))
+ (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 ((k (gensym "k")))
- (make-$let1v #f k name box body
- (make-$continue k (make-$primcall 'box (list sym))))))
+ (build-cps* (k)
+ ($letk ((k #f ($kargs (name) (sym) ,body)))
+ ($continue k ($primcall 'box (sym))))))
(else body)))
(match exp
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
- ((box #t)
- (make-$continue k (make-$primcall 'box-ref (list box))))
- ((subst #f) (make-$continue k (make-$var subst)))
- (#f (make-$continue k (make-$var sym)))))
- (($ <void> src) (make-$continue k (make-$void)))
- (($ <const> src exp) (make-$continue k (make-$const exp)))
- (($ <primitive-ref> src name) (make-$continue k (make-$prim name)))
+ ((box #t) (build-cps ($continue k ($primcall 'box-ref (box)))))
+ ((subst #f) (build-cps ($continue k ($var subst))))
+ (#f (build-cps ($continue k ($var sym))))))
+
+ (($ <void> src)
+ (build-cps ($continue k ($void))))
+
+ (($ <const> src exp)
+ (build-cps ($continue k ($const exp))))
+
+ (($ <primitive-ref> src name)
+ (build-cps ($continue k ($prim name))))
+
(($ <lambda> src meta body)
- ;; FIXME: propagate src to kentry
- (if (current-topbox-scope)
- (make-$continue k (make-$fun meta (gensym "self") '()
- (convert body 'ktail subst)))
- (let ((scope (gensym "scope"))
- (kscope (gensym "kscope")))
- (make-$let1k
- (make-$cont src kscope
- (make-$kargs '() '()
- (parameterize ((current-topbox-scope scope))
- (convert exp k subst))))
- (capture-toplevel-scope src scope kscope)))))
+ ;; FIXME: add src field to fun, add tail field also
+ (let ()
+ (define (convert-entries body)
+ (match body
+ (($ <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
+ (build-cps* (kentry kargs)
+ ,(build-fun-entry
+ ($kentry
+ kentry src ,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))))))
+ (if alternate (convert-entries alternate) '()))))))
+ (if (current-topbox-scope)
+ (build-cps* (self)
+ ($continue k
+ ($fun meta self '() ,(convert-entries body))))
+ (build-cps* (scope kscope)
+ ($letk ((kscope src ($kargs () ()
+ ,(parameterize ((current-topbox-scope
scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope kscope))))))
(($ <module-ref> src mod name public?)
(module-box
src mod name public? #t
(lambda (box)
- (make-$continue k (make-$primcall 'box-ref (list box))))))
+ (build-cps ($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)
- (make-$continue k (make-$primcall 'box-set! (list box val))))))))
+ (convert-arg exp
+ (lambda (val)
+ (module-box
+ src mod name public? #f
+ (lambda (box)
+ (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+
(($ <toplevel-ref> src name)
(toplevel-box
src name #t
(lambda (box)
- (make-$continue k (make-$primcall 'box-ref (list box))))))
+ (build-cps ($continue k ($primcall 'box-ref (box)))))))
+
(($ <toplevel-set> src name exp)
- (convert-arg
- exp
- (lambda (val)
- (toplevel-box
- src name #f
- (lambda (box)
- (make-$continue k (make-$primcall 'box-set! (list box val))))))))
+ (convert-arg exp
+ (lambda (val)
+ (toplevel-box
+ src name #f
+ (lambda (box)
+ (build-cps ($continue k ($primcall 'box-set! (box val)))))))))
+
(($ <toplevel-define> src name exp)
- (make-let src
- (lambda (k) (make-$continue k (make-$const name)))
- (lambda (name)
- (convert-arg
- exp
- (lambda (val)
- (make-$continue k (make-$primcall 'define! (list name
val))))))))
+ (convert-arg exp
+ (lambda (val)
+ (build-cps* (kname name-sym)
+ ($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) (make-$continue k (make-$call proc
args))))))
+ (match-lambda
+ ((proc . args)
+ (build-cps ($continue k ($call proc args)))))))
(($ <primcall> src name args)
(if (branching-primitive? name)
@@ -328,8 +397,8 @@
(make-const #f #f))
k subst)
(convert-args args
- (lambda (args)
- (make-$continue k (make-$primcall name args))))))
+ (lambda (args)
+ (build-cps ($continue k ($primcall name args)))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
@@ -350,101 +419,74 @@
(convert-arg
tag
(lambda (tag)
- (let ((khargs (gensym "khargs"))
- (khbody (gensym "khbody")))
- (make-$let1k
- (let ((hnames (append hreq (if hrest (list hrest) '()))))
- (make-$cont hsrc khbody
- (make-$kargs hnames hsyms
- (fold box-bound-var
- (convert hbody k subst)
- hnames hsyms))))
- (make-$let1k
- (make-$cont hsrc khargs
- (make-$ktrunc (make-$arity hreq '() hrest '() #f)
- khbody))
- (cond
- (escape-only?
- (let ((kret (gensym "kret"))
- (kprim (gensym "kvalues"))
- (prim (gensym "values"))
- (kpop (gensym "kpop"))
- (krest (gensym "krest"))
- (vals (gensym "vals")))
- (make-$letk*
- (list
- (make-$cont
- src kpop
- (make-$kargs
- (list 'rest) (list vals)
- (make-$let1k
- (make-$cont
- src kret
- (make-$kargs
- '() '()
- (make-$let1k
- (make-$cont
- src kprim
- (make-$kargs
- (list 'prim) (list prim)
- (make-$continue
- k
- (make-$primcall 'apply (list prim vals)))))
- (make-$continue kprim (make-$prim 'values)))))
- (make-$continue kret (make-$primcall 'pop-prompt '())))))
- (make-$cont src krest
- (make-$ktrunc (make-$arity '() '() 'rest '() #f)
- kpop)))
- (let ((kbody (gensym "kbody")))
- (if escape-only?
- (make-$let1k
- (make-$cont (tree-il-src body) kbody
- (convert body krest subst))
- (make-$continue kbody (make-$prompt #t tag khargs)))
- (convert-arg
- body
- (lambda (body)
- (make-$let1k
- (make-$cont
- (tree-il-src body) kbody
- (make-$continue
- krest
- (make-$primcall 'call-thunk/no-inline (list
body))))
- (make-$continue
- kbody
- (make-$prompt #f tag khargs)))))))))))))))))
+ (let ((hnames (append hreq (if hrest (list hrest) '()))))
+ (build-cps* (khargs khbody kret kprim prim kpop krest vals kbody)
+ ($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
+ ($letk ((kbody (tree-il-src body)
+ ($kargs () ()
+ ,(convert body krest subst))))
+ ($continue kbody ($prompt #t tag khargs))))
+ (convert-arg body
+ (lambda (thunk)
+ (build-cps
+ ($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)
- (make-$continue k (make-$primcall 'call-with-prompt args)))))
+ (build-cps
+ ($continue k ($primcall 'call-with-prompt args))))))
(($ <abort> src tag args tail)
(convert-args (append (list tag) args (list tail))
(lambda (args*)
- (make-$continue k (make-$primcall 'abort args*)))))
+ (build-cps ($continue k ($primcall 'abort args*))))))
(($ <conditional> src test consequent alternate)
- (let ((kif (gensym "kif"))
- (kt (gensym "k"))
- (kf (gensym "k")))
- (make-$letk*
- (list (make-$cont (tree-il-src consequent) kt
- (make-$kargs '() '() (convert consequent k subst)))
- (make-$cont (tree-il-src alternate) kf
- (make-$kargs '() '() (convert alternate k subst))))
- (make-$let1k
- (make-$cont src kif (make-$kif kt kf))
- (match test
- (($ <primcall> src (? branching-primitive? name) args)
- (convert-args args
- (lambda (args)
- (make-$continue kif (make-$primcall name args)))))
- (_ (convert-arg test
- (lambda (test)
- (make-$continue kif (make-$var test))))))))))
+ (build-cps* (kif kt kf)
+ ($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 ($continue kif ($primcall name args))))))
+ (_ (convert-arg test
+ (lambda (test)
+ (build-cps ($continue kif ($var test))))))))))
(($ <lexical-set> src name gensym exp)
(convert-arg
@@ -452,76 +494,55 @@
(lambda (exp)
(match (assq-ref subst gensym)
((box #t)
- (make-$continue k (make-$primcall 'box-set! (list box exp))))))))
-
- (($ <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)))))
- (make-$cont
- src (gensym "kentry")
- (make-$kentry
- arity
- (make-$cont
- src (gensym "kcase")
- (make-$kargs
- (fold-formals (lambda (name sym init names)
- (cons name names))
- '()
- arity gensyms inits)
- 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 k subst)
- arity gensyms inits)))
- (and alternate (convert alternate k subst))))))
+ (build-cps
+ ($continue k ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let ((ktrunc (gensym "ktrunc"))
- (kseq (gensym "kseq")))
- (make-$letk* (list (make-$cont (tree-il-src tail) kseq
- (make-$kargs '() '()
- (convert tail k subst)))
- (make-$cont src ktrunc
- (make-$ktrunc (make-$arity '() '() #f '()
#f)
- kseq)))
- (convert head ktrunc subst))))
+ (build-cps* (ktrunc kseq)
+ ($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 ((klet (gensym "k")))
- (make-$let1v src klet name sym
- (box-bound-var name sym (lp names syms vals))
- (convert val klet subst)))))))
+ (build-cps* (klet)
+ ($letk ((klet src ($kargs (name) (sym)
+ ,(box-bound-var name sym
+ (lp names syms vals)))))
+ ,(convert val klet subst)))))))
- (($ <fix> src names gensyms (($ <lambda> lsrc lmeta lbody) ...) body)
+ (($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
- (make-$letrec names gensyms
- (map (lambda (src meta body)
- ;; FIXME: propagate src to kentry
- (make-$fun meta (gensym "self") '()
- (convert body 'ktail subst)))
- lsrc lmeta lbody)
- (convert body k subst)))
+ (if (current-topbox-scope)
+ (build-cps* (self)
+ ($letrec names
+ gensyms
+ (map (lambda (fun)
+ (match (convert fun k subst)
+ (($ $continue _ (and fun ($ $fun)))
+ fun)))
+ funs)
+ ,(convert body k subst)))
+ (build-cps* (scope kscope)
+ ($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 () rest #f () syms body #f))
- (let* ((ktrunc (gensym "ktrunc"))
- (kargs (gensym "kargs"))
- (names (append req (if rest (list rest) '())))
- (arity (make-$arity req '() rest '() #f)))
- (make-$letk* (list (make-$cont src kargs
- (make-$kargs names syms
- (fold box-bound-var
- (convert body k subst)
- names syms)))
- (make-$cont src ktrunc
- (make-$ktrunc arity kargs)))
- (convert exp ktrunc subst))))))
+ (let ((names (append req (if rest (list rest) '()))))
+ (build-cps* (ktrunc kargs)
+ ($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
@@ -560,17 +581,13 @@ indicates that the replacement variable is in a box."
(convert exp 'ktail (build-subst exp)))
(define (cps-convert/thunk exp)
- (make-$fun '() (gensym "init") '()
- (make-$cont
- (tree-il-src exp)
- (gensym "kentry")
- (make-$kentry (make-$arity '() '() #f '() #f)
- (make-$cont
- (tree-il-src exp)
- (gensym "kinit")
- (make-$kargs '() '()
- (cps-convert exp)))
- #f))))
+ (let ((src (tree-il-src exp)))
+ (build-cps* (init kentry kinit)
+ ,(build-fun
+ ($fun '() init '()
+ (($kentry kentry src ('() '() #f '() #f)
+ (kinit src ($kargs () ()
+ ,(cps-convert exp))))))))))
(define *comp-module* (make-fluid))
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..ebc6673
--- /dev/null
+++ b/test-suite/tests/rtl-compilation.test
@@ -0,0 +1,81 @@
+;;;; 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 assembler))
+
+(define* (compile-via-rtl exp #:key peval? cse?)
+ (assemble-program
+ (compile exp #:to 'rtl #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define (run-rtl exp)
+ ((compile-via-rtl exp)))
+
+(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 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 1
+ (run-rtl '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-rtl '(cons 1 2)))
+
+ ;; FIXME: Not yet working.
+ #;
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-rtl '(values 1 2))) list))
+
+ ;; prompts
+ )
+
+(with-test-prefix "value context"
+ 1
+ )
+
+(with-test-prefix "drop context"
+ 1
+ )
+
+(with-test-prefix "test context"
+ 1
+ )
+
+(with-test-prefix "values context"
+ 1
+ )
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-182-gb1c738a,
Andy Wingo <=