[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-120-g5a44
|
From: |
Noah Lavine |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-120-g5a44ec4 |
|
Date: |
Thu, 08 Aug 2013 03:37:03 +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=5a44ec4c40a6bb6fa781cf4ab98526129fcfe0c0
The branch, wip-rtl-cps has been updated
via 5a44ec4c40a6bb6fa781cf4ab98526129fcfe0c0 (commit)
via 29dc9f7b60bf63a95781f991d2d1b43c7fea3e7b (commit)
via ecf40eca0f1906f34bf890299d11fb1c31df083c (commit)
via ebbc994de5d84d774d4661a894746ff4fa35db0d (commit)
via b80b2317bf46597377065324fdfb511fed24432c (commit)
via 845547a5a6faaffd09117e034a77c964caff4a7f (commit)
from 69e653ef032205ea2dd96e0b86ab8785f933348c (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 5a44ec4c40a6bb6fa781cf4ab98526129fcfe0c0
Author: Noah Lavine <address@hidden>
Date: Sat Aug 3 17:14:38 2013 -0400
Test cps->rtl
* module/language/cps/compile-rtl.scm: bugfixes.
* module/language/cps/primitives: a new table for primitive properties,
used to represent variable arities.
* module/language/cps/util.scm: add `maybe-append'.
* test-suite/tests/compile-rtl.test: tests for compile-rtl.
commit 29dc9f7b60bf63a95781f991d2d1b43c7fea3e7b
Author: Noah Lavine <address@hidden>
Date: Sat Aug 3 17:12:45 2013 -0400
Test Closure Conversion
* test-suite/tests/cps-closure-conversion.test: test closure conversion.
* module/language/cps/closure-conversion.scm: some bug fixes.
commit ecf40eca0f1906f34bf890299d11fb1c31df083c
Author: Noah Lavine <address@hidden>
Date: Sat Aug 3 17:11:33 2013 -0400
Bugfixes in cps-isomorphic
* module/language/cps/cps-isomorphic.scm: better error messages and a
bug fix.
commit ebbc994de5d84d774d4661a894746ff4fa35db0d
Author: Noah Lavine <address@hidden>
Date: Wed Jun 26 22:55:25 2013 -0400
Test tree-il->cps
* test-suite/tests/tree-il-to-cps.test: new tests.
* module/language/cps/cps-isomorphic.scm: supporting function for tests.
commit b80b2317bf46597377065324fdfb511fed24432c
Author: Noah Lavine <address@hidden>
Date: Thu Jun 20 23:47:24 2013 -0400
Split compile-rtl.scm
* module/language/cps/compile-rtl.scm: remove functions not directly
related to compilation.
* module/language/cps/util.scm: put them here.
commit 845547a5a6faaffd09117e034a77c964caff4a7f
Author: Noah Lavine <address@hidden>
Date: Thu Jun 20 23:42:00 2013 -0400
Add `cps-eval'
* module/language/cps/compile-rtl.scm: add function cps-eval.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/closure-conversion.scm | 91 +++++---
module/language/cps/compile-rtl.scm | 324 ++++++++++----------------
module/language/cps/cps-isomorphic.scm | 91 +++++++
module/language/cps/primitives.scm | 78 ++++---
module/language/cps/util.scm | 105 +++++++++
test-suite/tests/compile-rtl.test | 29 +++
test-suite/tests/cps-closure-conversion.test | 144 ++++++++++++
test-suite/tests/tree-il-to-cps.test | 135 +++++++++++
8 files changed, 731 insertions(+), 266 deletions(-)
create mode 100644 module/language/cps/cps-isomorphic.scm
create mode 100644 module/language/cps/util.scm
create mode 100644 test-suite/tests/compile-rtl.test
create mode 100644 test-suite/tests/cps-closure-conversion.test
create mode 100644 test-suite/tests/tree-il-to-cps.test
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 9cba8d2..f3053a4 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -93,35 +93,70 @@
env)))))
((<letrec> names funcs body)
- ;; with a letrec, we need to run the primitive make-closure (and
- ;; maybe later fix-closure too) to generate the procedures, and
- ;; then run the body of the letrec in an environment with the
- ;; procedures available. so we actually don't use the letrec
- ;; machinery - we replace the letrec names with dummies and turn
- ;; the letrec names into arguments of make-closure's
- ;; continuation. this is really ugly.
- (let* ((func (car funcs))
- (closure-env (alloc-closure-vals
- (free-vals func)))
- (new-names (map (lambda (n) (gensym "dummy-")) names)))
+ (let* ((closure-envs
+ ;; we make the names the prefix of all of the closure
+ ;; name lists so that the closed-over functions will be
+ ;; able to refer to each other.
+ (map (lambda (func) (alloc-closure-vals
+ (append
+ names
+ (free-vals func))))
+ funcs))
+ (dummies (map (lambda (n) (gensym "dummy-")) names))
+ (unspec-name (gensym "unspec-")))
(make-letrec
- new-names
- (list (visit func closure-env))
- (let ((con (gensym "con-")))
- ;; first make the closure, then run the body of the letrec.
- ;; Note: we only allow a single closure in the letrec right
- ;; now.
- (make-letcont
- (list con)
- (list (make-lambda
- names #f (visit body env)))
- (make-call
- (make-primitive 'make-closure)
- con
- ;; the first argument of a make-closure call is special.
- (cons (car new-names)
- (free-vals func))))))))
-
+ ;; after closure conversion, lambda objects don't have lexical
+ ;; environments. the "dummies" refer to the new lambda
+ ;; objects, and the names from the original letrec will refer
+ ;; to the new closure objects.
+ dummies
+ (map (lambda (func env)
+ (visit func env))
+ funcs closure-envs)
+ ;; we need a dummy value to put in closures before we call
+ ;; fix-closure. we use *unspecified*.
+ (make-letval
+ (list unspec-name)
+ (list (make-const *unspecified*))
+ ;; iterate over the list of functions, generating a
+ ;; make-closure call for each one
+ (let iter ((funcs-tail funcs)
+ (dummies-tail dummies)
+ (names-tail names))
+ (if (not (null? funcs-tail))
+ (let ((con (gensym "con-")))
+ (make-letcont
+ (list con)
+ (list (make-lambda
+ (list (car names-tail)) #f
+ (iter (cdr funcs-tail)
+ (cdr dummies-tail)
+ (cdr names-tail))))
+ (make-call
+ (make-primitive 'make-closure)
+ con
+ (cons (car dummies-tail)
+ (append (map (lambda (n) unspec-name) names)
+ (free-vals (car funcs-tail)))))))
+ ;; we always fix up the closure even if there's only
+ ;; one function, because it might refer to itself.
+ (let iter ((funcs-tail funcs)
+ (names-tail names))
+ (let ((con (gensym "con-")))
+ (make-letcont
+ (list con)
+ (list (make-lambda
+ '() #f
+ (if (not (null? (cdr funcs-tail)))
+ (iter (cdr funcs-tail)
+ (cdr names-tail))
+ (visit body env))))
+ (make-call
+ (make-primitive 'fix-closure)
+ con
+ (cons (car names-tail)
+ names)))))))))))
+
((<letcont> names conts body)
(make-letcont
names
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 793c293..be0edb0 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -3,16 +3,17 @@
#:use-module (language cps primitives)
#:use-module (language cps allocate)
#:use-module (language cps closure-conversion)
+ #:use-module (language cps util)
#:use-module (system base syntax) ;; for record-case
#:use-module (ice-9 match)
- #:use-module (ice-9 q) ;; used in generate-shuffle
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (system base compile)
#:use-module (language tree-il compile-cps)
#:use-module (system vm assembler)
- #:export (cps->rtl generate-shuffle generate-rtl cps-compile
- calculate-free-values))
+ #:export (cps->rtl generate-rtl cps-compile
+ calculate-free-values cps-eval
+ generate-primitive-call))
;; currently, the only way we have to run RTL code is to package it up
;; into a program and call that program. Therefore, all code that we
@@ -139,207 +140,124 @@
free-vals)
-;; this function should probably be in (ice-9 q)
-(define (append-qs! q r)
- (set-cdr! (cdr q) (car r))
- (set-cdr! q (cdr r))
- q)
+;; the next few functions define special cases for certain VM
+;; instructions. it's usually because they need special arguments.
+
+;; ref and set need to know if they're handling a module variable or
+;; not. The most elegant thing from the CPS point of view is to forget
+;; about the module-ref and module-set VM instructions and just use
+;; resolve for everything, but that might be slow until we have a tiling
+;; code generator.
+(define (generate-ref dst args name-defn register)
+ (let* ((var-value (car args))
+ ;; var-value is the value holding the variable object, var is
+ ;; the actual variable object
+ (var (name-defn var-value)))
+ (if (module-var? var)
+ ;; the scope is 'foo because we don't meaningfully
+ ;; distinguish scopes yet.
+ (if (eq? (module-var-module var) 'toplevel)
+ ;; we should really just cache the current module
+ ;; once per procedure.
+ `((cache-current-module! ,dst foo)
+ (cached-toplevel-ref ,dst foo
+ ,(module-var-name var)))
+ `((cached-module-ref ,dst
+ ,(module-var-module var)
+ ,(module-var-public? var)
+ ,(module-var-name var))))
+ `((box-ref ,dst ,(register var-value))))))
+
+(define (generate-set dst args name-defn register)
+ (let* ((var-value (car args))
+ (new-value (cadr args))
+ (var (name-defn var-value)))
+ (if (module-var? var)
+ (if (eq? (module-var-module var) 'toplevel)
+ `((cache-current-module! ,dst foo)
+ (cached-toplevel-set! ,(register new-value) foo
+ ,(module-var-name var))
+ (mov ,dst ,(register new-value)))
+ `((cached-module-set! ,(register new-value)
+ ,(module-var-module var)
+ ,(module-var-public? var)
+ ,(module-var-name var))
+ (mov ,dst ,(register new-value))))
+ `((box-set!
+ ,(register var-value)
+ ,(register new-value))
+ (mov ,dst ,(register new-value))))))
+
+;; closure-ref needs to know the value of its argument at compile time,
+;; so it has to look that up in the name-defn table.
+(define (generate-closure-ref dst args name-defn)
+ (let ((defn (name-defn (car args))))
+ (when (not (const? defn))
+ (error
+ "closure-ref must be called with a constant argument"))
+ `((free-ref
+ ,dst
+ ,(const-value defn)))))
+
+;; make-closure's first argument is a label, not a register.
+(define (generate-make-closure dst args label register)
+ (let ((func (car args))
+ (vals (cdr args)))
+ `((make-closure
+ ,dst
+ ,(label func)
+ ,(map register vals)))))
+
+;; generate-primitive-call: generate a call to primitive prim with the
+;; given args, placing the result in register(s) dsts. rest is either
+;; #f or the location of the rest arguments of the destination
+;; continuation (if it has rest arguments).
+(define (generate-primitive-call dsts rest prim args
+ name-defn label register)
+ (define (has-prop? primitive prop)
+ (memq prop (hashq-ref *primitive-props-table* primitive)))
+
+ ;; TO DO: let primitives indicate the type of their arguments, with
+ ;; options 'register and 'label, and maybe more. That would let us
+ ;; remove the special handling for some of them, and implement things
+ ;; like prompt and dynwind.
+
+ (catch 'bad-primitive
+ (lambda ()
+ (let ((dst (if (pair? dsts) (car dsts) rest)))
+ ;; if out-arity is 0, dst will be junk, but it shouldn't error.
+ (case prim
+ ((ref) (generate-ref dst args name-defn register))
+ ((set) (generate-set dst args name-defn register))
+ ((closure-ref) (generate-closure-ref dst args name-defn))
+ ((make-closure) (generate-make-closure dst args label register))
+ (else
+ (let ((insn (hashq-ref *primitive-insn-table* prim))
+ (in-arity (hashq-ref *primitive-in-arity-table* prim))
+ (out-arity (hashq-ref *primitive-out-arity-table* prim)))
+ (unless insn
+ (throw 'bad-primitive))
+ (unless (or (has-prop? prim 'variable)
+ (= in-arity (length args)))
+ (throw 'bad-primitive))
+
+ (let ((fix-args (list-head args in-arity))
+ (var-args (list-tail args in-arity)))
+ (list
+ (maybe-append
+ (list insn)
+ (and (= out-arity 1)
+ (list dst))
+ (map register fix-args)
+ (and (has-prop? prim 'variable)
+ (list (map register var-args)))))))))))
+ (lambda (key)
+ (error "malformed primitive call" (cons prim args)))))
-;; and this is some sort of general utility
-(define (int-range start end)
- (if (< start end)
- (cons start (int-range (+ start 1) end))
- '()))
-
-;; this function returns a list of `mov' instructions that accomplish a
-;; shuffle in the stack. each tail argument is a pair (from . to) that
-;; indicates how a value should move. the first argument is the number
-;; of an extra slot that it can use as swap space if it wants to. NOTE:
-;; if the VM had a `swap' instruction, we wouldn't need an extra
-;; spot. maybe we should add one.
-(define (generate-shuffle swap . args)
- ;; a "move chain" is ((x1 . x2) (x2 . x3) ...). we return a list of
- ;; the swap chains we find in our args, as (ice-9 q) queues.
- (define (make-move-chains chains rest)
- ;; chains is a list of queues of elements, each of which is a move
- ;; chain, and rest is a list of whatever moves have yet to be
- ;; chained.
- (if (null? rest)
- chains
- (let* ((next (car rest))
- (front-match (find (lambda (x) (eq? (car (q-front x)) (cdr
next)))
- chains))
- (end-match (find (lambda (x) (eq? (cdr (q-rear x)) (car next)))
- chains)))
- ;; it is possible to get a front-match and an end-match at the
- ;; same time in two different ways. if our set of moves
- ;; includes a cycle, then we expect that at some point, the
- ;; front-match and end-match will be eq?. we need to serialize
- ;; our cycles anyway, so we just pick the front-match
- ;; arbitrarily. however, if we have a front-match and an
- ;; end-match that are not eq?, then it means we have found a
- ;; link between two of our chains, and we need to stitch them
- ;; together.
- (cond
- ((and front-match end-match (not (eq? front-match end-match)))
- ;; stitch two chains together
- (enq! end-match next)
- (append-qs! end-match front-match)
- (make-move-chains (delq front-match chains) (cdr rest)))
- (front-match ;; push next onto the beginning of a chain
- (q-push! front-match next)
- (make-move-chains chains (cdr rest)))
- (end-match ;; push next onto the end of a chain
- (enq! end-match next)
- (make-move-chains chains (cdr rest)))
- (else ;; make a new chain
- (let ((new-chain (make-q)))
- (enq! new-chain next)
- (make-move-chains (cons new-chain chains) (cdr rest))))))))
-
- ;; given a single move chain, generate a series of moves to implement
- ;; it, using the given swap register
- (define (moves-for-chain swap chain)
- (if (eq? (car (q-front chain))
- (cdr (q-rear chain)))
- ;; a cyclic chain!
- `((mov ,swap ,(car (q-front chain)))
- ;; we remove the first element of the chain, making it acyclic
- ,@(moves-for-acyclic-list (cdar chain))
- (mov ,(cdr (q-front chain)) ,swap))
- (moves-for-acyclic-list (car chain))))
-
- (define (moves-for-acyclic-list lst)
- ;; this is named -list instead of -chain because it accepts a list
- ;; holding a move chain, instead of a queue like the other -chain
- ;; functions.
- (let iter ((moves (reverse lst)))
- (if (null? moves)
- '()
- (cons `(mov ,(cdar moves) ,(caar moves))
- (iter (cdr moves))))))
-
- ;; step one: eliminate identity shuffles
- (let* ((no-ids (remove (lambda (x) (eq? (car x) (cdr x))) args))
- ;; step two: make move chains
- (chains (make-move-chains '() no-ids)))
- ;; step three: generate a series of moves for each chain, using the
- ;; swap space.
- (apply append (map (lambda (x) (moves-for-chain swap x)) chains))))
;; generate-rtl compiles a CPS form to RTL.
(define (generate-rtl cps name-defn register call-frame-start
rest-args-start nlocals label next-label!)
- ;; generate-primitive-call: generate a call to primitive prim with the
- ;; given args, placing the result in register(s) dsts. rest is either
- ;; #f or the location of the rest arguments of the destination
- ;; continuation (if it has rest arguments). This is its own function
- ;; because it is called twice in visit - once in the tail case and
- ;; once in the non-tail case.
- (define (generate-primitive-call dsts rest prim args)
- ;; some of the primitives have special handling. this probably
- ;; points to a bad abstraction, but I don't know where yet. the
- ;; distinction is whether the primitives require information that is
- ;; part of the CPS or not. A "regular" primitive takes Scheme values
- ;; from registers and returns Scheme values to registers. These
- ;; primitives are handled in the primitive instruction tables in
- ;; (language cps primitives). However, other primitives are
- ;; different, in different ways:
-
- ;; ref and set need to know if they're handling a module variable or
- ;; not. The most elegant thing from the CPS point of view is to
- ;; forget about the module-ref and module-set VM instructions and
- ;; just use resolve for everything, but that might be slow until we
- ;; have a tiling code generator.
-
- ;; closure-ref needs to know the value of its argument at compile
- ;; time, so it has to look that up in the name-defn table.
-
- ;; make-closure's first argument is a label, not a register.
-
- ;; in the future, things like prompt and dynwind will take arguments
- ;; that are lambdas in Scheme, but are actually continuations in CPS
- ;; world, so they'll have to know how to turn them into
- ;; continuations.
-
- (case prim
- ((ref) (let* ((var-value (car args))
- ;; var-value is the value holding the variable
- ;; object
- (var (name-defn var-value))
- ;; var is the actual variable object
- (dst (if (pair? dsts)
- (car dsts)
- rest)))
- (if (module-var? var)
- ;; the scope is 'foo because we don't meaningfully
- ;; distinguish scopes yet.
- (if (eq? (module-var-module var) 'toplevel)
- ;; we should really just cache the current module
- ;; once per procedure.
- `((cache-current-module! ,dst foo)
- (cached-toplevel-ref ,dst foo
- ,(module-var-name var)))
- `((cached-module-ref ,dst
- ,(module-var-module var)
- ,(module-var-public? var)
- ,(module-var-name var))))
- `((box-ref ,dst ,(register var-value))))))
- ((set) (let* ((var-value (car args))
- (new-value (cadr args))
- (var (name-defn var-value))
- (dst (if (pair? dsts)
- (car dsts)
- rest)))
- (if (module-var? var)
- (if (eq? (module-var-module var) 'toplevel)
- `((cache-current-module! ,dst foo)
- (cached-toplevel-set! ,(register new-value) foo
- ,(module-var-name var))
- (mov ,dst ,(register new-value)))
- `((cached-module-set! ,(register new-value)
- ,(module-var-module var)
- ,(module-var-public? var)
- ,(module-var-name var))
- (mov ,dst ,(register new-value))))
- `((box-set!
- ,(register var-value)
- ,(register new-value))
- (mov ,dst ,(register new-value))))))
-
- ((closure-ref) (let* ((dst (if (pair? dsts)
- (car dsts)
- rest))
- (defn (name-defn (car args))))
- (when (not (const? defn))
- (error
- "closure-ref must be called with a constant
argument"))
- `((free-ref
- ,dst
- ,(const-value defn)))))
-
- ((make-closure) (let ((dst (if (pair? dsts)
- (car dsts)
- rest))
- (func (car args))
- (vals (cdr args)))
- `((make-closure
- ,dst
- ,(label func)
- ,(map register vals)))))
- (else
- (let ((insn (hashq-ref *primitive-insn-table* prim))
- (in-arity (hashq-ref *primitive-in-arity-table* prim))
- (out-arity (hashq-ref *primitive-out-arity-table* prim))
- (dst (if (pair? dsts)
- (car dsts)
- rest)))
- (if (and insn
- (= in-arity (length args))
- (= out-arity 1)) ;; we don't support n-ary outputs yet
- `((,insn ,dst ,@(map register args)))
- (error "malformed primitive call" (cons prim args)))))))
-
(define (visit cps)
;; cps is either a let expression or a call
(match cps
@@ -364,7 +282,8 @@
(let ((return-reg
(+ 1 (apply max (map register args)))))
`(,@(generate-primitive-call
- (list return-reg) #f (primitive-name proc) args)
+ (list return-reg) #f (primitive-name proc) args
+ name-defn label register)
(return ,return-reg))))
(($ <call> proc 'return args)
@@ -405,7 +324,8 @@
(perm-label (next-label!)))
(if (primitive? proc)
`(,@(generate-primitive-call
- dsts rest (primitive-name proc) args)
+ dsts rest (primitive-name proc) args
+ name-defn label register)
(br ,(label cont)))
`((call ,(call-frame-start cps) ,(register proc)
,(map register args))
@@ -504,3 +424,5 @@
#:from 'rtl #:to to))
((rtl) (assemble-program x))
(else (error "Unrecognized language" from))))))
+
+(define (cps-eval x) ((cps-compile `(lambda () ,x))))
diff --git a/module/language/cps/cps-isomorphic.scm
b/module/language/cps/cps-isomorphic.scm
new file mode 100644
index 0000000..a997d35
--- /dev/null
+++ b/module/language/cps/cps-isomorphic.scm
@@ -0,0 +1,91 @@
+(define-module (language cps cps-isomorphic)
+ #:use-module (language cps)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:export (cps-isomorphic?))
+
+;; our goal is to say when two pieces of CPS are isomorphic. This is
+;; useful in testing the CPS compiler. We take advantage of the fact
+;; that CPS names are unique to keep all of ours in one big hash table.
+
+(define (cps-isomorphic? x y)
+ (let ((x-to-y-names (make-hash-table)))
+ ;; this function adds names to the name table while also checking
+ ;; that the name lists are of the same length.
+ (define (match-names! x-names y-names)
+ (cond ((and (null? x-names) (null? y-names))
+ #t)
+ ((and (pair? x-names) (pair? y-names))
+ (hashq-set! x-to-y-names
+ (car x-names) (car y-names))
+ (match-names! (cdr x-names) (cdr y-names)))
+ (else
+ (pk "Couldn't match" (car x-names) (car y-names))
+ #f)))
+
+ (define (names-match? x y x-name y-name)
+ (or (eq? (hashq-ref x-to-y-names x-name) y-name)
+ (begin (pk "Couldn't match" x y) #f)))
+
+ ;; one continuation has a special name.
+ (match-names! '(return) '(return))
+
+ (let rec ((x x) (y y))
+ (match (cons x y)
+ ((($ <letval> x-names x-vals x-body) .
+ ($ <letval> y-names y-vals y-body))
+ (and (every rec x-vals y-vals)
+ (match-names! x-names y-names)
+ (rec x-body y-body)))
+ ((($ <letcont> x-names x-conts x-body) .
+ ($ <letcont> y-names y-conts y-body))
+ (and (match-names! x-names y-names)
+ (every rec x-conts y-conts)
+ (rec x-body y-body)))
+ ((($ <letrec> x-names x-funcs x-body) .
+ ($ <letrec> y-names y-funcs y-body))
+ (and (match-names! x-names y-names)
+ (every rec x-funcs y-funcs)
+ (rec x-body y-body)))
+ ((($ <const> x-val) . ($ <const> y-val))
+ (if (equal? x-val y-val)
+ #t
+ (begin (pk "Couldn't match" x y)
+ #f)))
+ ((($ <var> x-val) . ($ <var> y-val))
+ (names-match? x y x-val y-val))
+ ((($ <lambda> x-names x-rest x-body) .
+ ($ <lambda> y-names y-rest y-body))
+ (and (match-names! x-names y-names)
+ (cond
+ ((and (not x-rest) (not y-rest)) #t)
+ ((and x-rest y-rest)
+ (match-names! (list x-rest) (list y-rest)))
+ (else (pk "couldn't match" x y) #f))
+ (rec x-body y-body)))
+ ((($ <call> x-proc x-cont x-args) .
+ ($ <call> y-proc y-cont y-args))
+ (and (cond ((and (primitive? x-proc)
+ (primitive? y-proc))
+ (eq? (primitive-name x-proc)
+ (primitive-name y-proc)))
+ ((and (symbol? x-proc) (symbol? y-proc))
+ (names-match? x y x-proc y-proc))
+ (else (pk "Couldn't match" x y) #f))
+ (names-match? x y x-cont y-cont)
+ (every (lambda (x-arg y-arg)
+ (names-match? x y x-arg y-arg))
+ x-args y-args)))
+ ((($ <module-var> x-mod x-name x-public) .
+ ($ <module-var> y-mod y-name y-public))
+ (and (equal? x-mod y-mod)
+ (eq? x-name y-name)
+ (eq? x-public y-public)))
+ ((($ <if> x-test x-then x-else) .
+ ($ <if> y-test y-then y-else))
+ (and (names-match? x y x-test y-test)
+ (names-match? x y x-then y-then)
+ (names-match? x y x-else y-else)))
+ ((x . y) (pk "Couldn't match" x y) #f)
+ (other (error "Internal error" other))))))
+
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 7a93138..5a1176e 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -1,43 +1,44 @@
(define-module (language cps primitives)
#:export (*primitive-insn-table*
*primitive-in-arity-table*
- *primitive-out-arity-table*))
+ *primitive-out-arity-table*
+ *primitive-props-table*))
-;; the "primitives" in this file are the operations which are supported
-;; by VM opcodes. Each primitive has more than one name - there is its
-;; name in the (guile) module, its name in a <primitive> record (which
-;; is always the same as its name in (guile), for simplicity) and its
-;; name as a VM instruction, which may be different from the first two.
-
-;; this list holds information about the primitive VM operations. The
-;; current fields are (Scheme name, VM name, in-arity). We don't handle
-;; folds, reductions, or variable-arity instructions yet.
(define *primitive-insn-data*
- '((string-length string-length 1)
- (string-ref string-ref 2)
- (string->number string->number 1)
- (string->symbol string->symbol 1)
- (symbol->keyword symbol->keyword 1)
- (cons cons 2)
- (car car 1)
- (cdr cdr 1)
- (+ add 2)
- (1+ add1 1)
- (- sub 2)
- (1- sub1 1)
- (* mul 2)
- (/ div 2)
+ ;; fields:
+ ;; (Scheme name, VM name, in arity, out arity, props ...)
+
+ ;; "Scheme name" is what will appear in CPS <primitive> records, and
+ ;; also the corresponding procedure's name in the (guile) module if it
+ ;; has one. "out arity" must be 0 or 1. "in arity" is the minimum in
+ ;; arity. if the primitive accepts more than that, it should have the
+ ;; "variable" property.
+ '((string-length string-length 1 1)
+ (string-ref string-ref 2 1)
+ (string->number string->number 1 1)
+ (string->symbol string->symbol 1 1)
+ (symbol->keyword symbol->keyword 1 1)
+ (cons cons 2 1)
+ (car car 1 1)
+ (cdr cdr 1 1)
+ (+ add 2 1)
+ (1+ add1 1 1)
+ (- sub 2 1)
+ (1- sub1 1 1)
+ (* mul 2 1)
+ (/ div 2 1)
;; quo isn't here because I don't know which of our many types of
;; division it's supposed to be. same for rem and mod.
- (ash ash 2)
- (logand logand 2)
- (logior logior 2)
- (logxor logxor 2)
- (vector-length vector-length 1)
- (vector-ref vector-ref 2)
- (struct-vtable struct-vtable 1)
- (struct-ref struct-ref 2)
- (class-of class-of 1)))
+ (ash ash 2 1)
+ (logand logand 2 1)
+ (logior logior 2 1)
+ (logxor logxor 2 1)
+ (vector-length vector-length 1 1)
+ (vector-ref vector-ref 2 1)
+ (struct-vtable struct-vtable 1 1)
+ (struct-ref struct-ref 2 1)
+ (class-of class-of 1 1)
+ (fix-closure fix-closure 1 0 variable)))
;; this table maps our names for primitives (which are the Scheme names)
;; to the corresponding VM instructions. It also does double duty as the
@@ -54,11 +55,12 @@
;; this table holds the number of inputs each primitive function takes
(define *primitive-in-arity-table* (make-hash-table))
-;; and this one holds the number of outputs. this will always be 1 right
-;; now, but there are cases where that won't be true - for instance,
-;; divmod.
+;; and this one holds the number of outputs.
(define *primitive-out-arity-table* (make-hash-table))
+;; this is for miscellaneous properties
+(define *primitive-props-table* (make-hash-table))
+
(define (fill-insn-tables!)
(for-each
(lambda (entry)
@@ -67,7 +69,9 @@
(hashq-set! *primitive-in-arity-table*
(car entry) (caddr entry))
(hashq-set! *primitive-out-arity-table*
- (car entry) 1))
+ (car entry) (cadddr entry))
+ (hashq-set! *primitive-props-table*
+ (car entry) (cddddr entry)))
*primitive-insn-data*))
(fill-insn-tables!)
diff --git a/module/language/cps/util.scm b/module/language/cps/util.scm
new file mode 100644
index 0000000..a5de593
--- /dev/null
+++ b/module/language/cps/util.scm
@@ -0,0 +1,105 @@
+(define-module (language cps util)
+ #:use-module (ice-9 q)
+ #:use-module (srfi srfi-1)
+ #:export (append-qs! int-range maybe-append generate-shuffle))
+
+;; The functions in this file are not directly related to CPS or
+;; compilation; they're here because the CPS compiler needs them and
+;; they haven't found a better place in the module structure yet.
+
+;; this function should probably be in (ice-9 q)
+(define (append-qs! q r)
+ (set-cdr! (cdr q) (car r))
+ (set-cdr! q (cdr r))
+ q)
+
+;; and this is some sort of general utility
+(define (int-range start end)
+ (if (< start end)
+ (cons start (int-range (+ start 1) end))
+ '()))
+
+;; this is a totally generic utility
+(define (maybe-append . args)
+ (cond ((null? args) '())
+ ((eq? (car args) #f)
+ (apply maybe-append (cdr args)))
+ (else
+ (append (car args)
+ (apply maybe-append (cdr args))))))
+
+;; this function returns a list of `mov' instructions that accomplish a
+;; shuffle in the stack. each tail argument is a pair (from . to) that
+;; indicates how a value should move. the first argument is the number
+;; of an extra slot that it can use as swap space if it wants to. NOTE:
+;; if the VM had a `swap' instruction, we wouldn't need an extra
+;; spot. maybe we should add one.
+(define (generate-shuffle swap . args)
+ ;; a "move chain" is ((x1 . x2) (x2 . x3) ...). we return a list of
+ ;; the swap chains we find in our args, as (ice-9 q) queues.
+ (define (make-move-chains chains rest)
+ ;; chains is a list of queues of elements, each of which is a move
+ ;; chain, and rest is a list of whatever moves have yet to be
+ ;; chained.
+ (if (null? rest)
+ chains
+ (let* ((next (car rest))
+ (front-match (find (lambda (x) (eq? (car (q-front x)) (cdr
next)))
+ chains))
+ (end-match (find (lambda (x) (eq? (cdr (q-rear x)) (car next)))
+ chains)))
+ ;; it is possible to get a front-match and an end-match at the
+ ;; same time in two different ways. if our set of moves
+ ;; includes a cycle, then we expect that at some point, the
+ ;; front-match and end-match will be eq?. we need to serialize
+ ;; our cycles anyway, so we just pick the front-match
+ ;; arbitrarily. however, if we have a front-match and an
+ ;; end-match that are not eq?, then it means we have found a
+ ;; link between two of our chains, and we need to stitch them
+ ;; together.
+ (cond
+ ((and front-match end-match (not (eq? front-match end-match)))
+ ;; stitch two chains together
+ (enq! end-match next)
+ (append-qs! end-match front-match)
+ (make-move-chains (delq front-match chains) (cdr rest)))
+ (front-match ;; push next onto the beginning of a chain
+ (q-push! front-match next)
+ (make-move-chains chains (cdr rest)))
+ (end-match ;; push next onto the end of a chain
+ (enq! end-match next)
+ (make-move-chains chains (cdr rest)))
+ (else ;; make a new chain
+ (let ((new-chain (make-q)))
+ (enq! new-chain next)
+ (make-move-chains (cons new-chain chains) (cdr rest))))))))
+
+ ;; given a single move chain, generate a series of moves to implement
+ ;; it, using the given swap register
+ (define (moves-for-chain swap chain)
+ (if (eq? (car (q-front chain))
+ (cdr (q-rear chain)))
+ ;; a cyclic chain!
+ `((mov ,swap ,(car (q-front chain)))
+ ;; we remove the first element of the chain, making it acyclic
+ ,@(moves-for-acyclic-list (cdar chain))
+ (mov ,(cdr (q-front chain)) ,swap))
+ (moves-for-acyclic-list (car chain))))
+
+ (define (moves-for-acyclic-list lst)
+ ;; this is named -list instead of -chain because it accepts a list
+ ;; holding a move chain, instead of a queue like the other -chain
+ ;; functions.
+ (let iter ((moves (reverse lst)))
+ (if (null? moves)
+ '()
+ (cons `(mov ,(cdar moves) ,(caar moves))
+ (iter (cdr moves))))))
+
+ ;; step one: eliminate identity shuffles
+ (let* ((no-ids (remove (lambda (x) (eq? (car x) (cdr x))) args))
+ ;; step two: make move chains
+ (chains (make-move-chains '() no-ids)))
+ ;; step three: generate a series of moves for each chain, using the
+ ;; swap space.
+ (apply append (map (lambda (x) (moves-for-chain swap x)) chains))))
diff --git a/test-suite/tests/compile-rtl.test
b/test-suite/tests/compile-rtl.test
new file mode 100644
index 0000000..51fda7d
--- /dev/null
+++ b/test-suite/tests/compile-rtl.test
@@ -0,0 +1,29 @@
+(use-modules
+ (test-suite lib)
+ (language cps)
+ (language cps compile-rtl))
+
+(with-test-prefix "generate-primitive-call"
+ (pass-if-equal "arity: 1 -> 1"
+ '((string-length 1 0))
+ (let ((regs (make-object-property)))
+ (set! (regs 'a) 0)
+ (generate-primitive-call '(1) #f 'string-length '(a)
+ #f #f regs)))
+
+ (pass-if-equal "arity: 2 -> 1"
+ '((cons 2 0 1))
+ (let ((regs (make-object-property)))
+ (set! (regs 'a) 0)
+ (set! (regs 'b) 1)
+ (generate-primitive-call '(2) #f 'cons '(a b)
+ #f #f regs)))
+
+ (pass-if-equal "arity: variable -> 0"
+ '((fix-closure 0 (1 2)))
+ (let ((regs (make-object-property)))
+ (set! (regs 'a) 0)
+ (set! (regs 'b) 1)
+ (set! (regs 'c) 2)
+ (generate-primitive-call '() #f 'fix-closure '(a b c)
+ #f #f regs))))
diff --git a/test-suite/tests/cps-closure-conversion.test
b/test-suite/tests/cps-closure-conversion.test
new file mode 100644
index 0000000..b5cb86c
--- /dev/null
+++ b/test-suite/tests/cps-closure-conversion.test
@@ -0,0 +1,144 @@
+(use-modules
+ (test-suite lib)
+ (language cps)
+ (language cps compile-rtl)
+ (language cps closure-conversion)
+ (language cps cps-isomorphic))
+
+(define (cc cps)
+ (closure-convert cps (calculate-free-values cps)))
+
+(pass-if "call"
+ (cps-isomorphic?
+ (cc (parse-cps '(lambda (x) #f
+ (letrec
+ (func)
+ ((lambda () #f (call return #f (x))))
+ (call return #f (func))))))
+ (parse-cps
+ `(lambda (x) #f
+ (letrec
+ (func)
+ ((lambda () #f
+ (letval (n) ((const 1))
+ (letcont (ref-k)
+ ((lambda (x-val) #f
+ (call return #f (x-val))))
+ (call (primitive closure-ref) ref-k (n))))))
+ (letval (unspec) ((const ,*unspecified*))
+ (letcont
+ (closure-k)
+ ((lambda (cl) #f
+ (letcont
+ (fixed-k)
+ ((lambda () #f (call return #f (cl))))
+ (call (primitive fix-closure) fixed-k (cl cl)))))
+ (call (primitive make-closure) closure-k (func unspec x)))))))))
+
+(pass-if "letval"
+ (cps-isomorphic?
+ (cc (parse-cps '(lambda (x) #f
+ (letrec
+ (func)
+ ((lambda () #f
+ (letval (x-var) ((var x))
+ (call return #f (x-var)))))
+ (call return #f (func))))))
+ (parse-cps
+ `(lambda (x) #f
+ (letrec
+ (func)
+ ((lambda () #f
+ (letval (n) ((const 1))
+ (letcont
+ (ref-k)
+ ((lambda (val) #f
+ (letval (x-var) ((var val))
+ (call return #f (x-var)))))
+ (call (primitive closure-ref) ref-k (n))))))
+ (letval
+ (unspec)
+ ((const ,*unspecified*))
+ (letcont
+ (closure-k)
+ ((lambda (cl) #f
+ (letcont
+ (fixed-k)
+ ((lambda () #f
+ (call return #f (cl))))
+ (call (primitive fix-closure) fixed-k (cl cl)))))
+ (call (primitive make-closure) closure-k (func unspec x)))))))))
+
+(pass-if "letrec"
+ (cps-isomorphic?
+ (cc (parse-cps '(lambda (x) #f
+ (letval (x-var) ((var x))
+ (letrec
+ (get set)
+ ((lambda () #f
+ (call (primitive ref) return
(x-var)))
+ (lambda (val) #f
+ (call (primitive set) return
(x-var val))))
+ (letval (values-var)
+ ((module-var toplevel values #t))
+ (letcont
+ (values-k)
+ ((lambda (values) #f
+ (call values return
(get set))))
+ (call (primitive ref) values-k
(values-var)))))))))
+ (parse-cps
+ `(lambda (x) #f
+ (letval (x-var) ((var x))
+ (letrec
+ (get-code set-code)
+ ((lambda () #f
+ (letval (idx-0) ((const 2))
+ (letcont
+ (do-get)
+ ((lambda (closure-var) #f
+ (call (primitive ref) return
(closure-var))))
+ (call (primitive closure-ref) do-get
(idx-0)))))
+ (lambda (new-val) #f
+ (letval (idx-0) ((const 2))
+ (letcont
+ (do-set)
+ ((lambda (closure-var) #f
+ (call (primitive set) return
(closure-var new-val))))
+ (call (primitive closure-ref) do-set
(idx-0))))))
+
+ (letval
+ (unspec-name)
+ ((const ,*unspecified*))
+ (letcont
+ (get-closure)
+ ((lambda (get-c) #f
+ (letcont
+ (set-closure)
+ ((lambda (set-c) #f
+ (letcont
+ (fixed-get)
+ ((lambda () #f
+ (letcont
+ (fixed-set)
+ ((lambda () #f
+ (letval
(values-var)
+
((module-var toplevel values #t))
+
(letcont
+
(values-k)
+
((lambda (values) #f
+
(call values return (get-c set-c))))
+ (call
(primitive ref) values-k (values-var))))))
+ (call (primitive
fix-closure)
+ fixed-set
+ (set-c get-c
set-c)))))
+ (call (primitive fix-closure)
+ fixed-get
+ (get-c get-c set-c)))))
+ (call (primitive make-closure)
+ set-closure
+ (set-code unspec-name unspec-name
+ x-var)))))
+ (call (primitive make-closure)
+ get-closure
+ (get-code unspec-name unspec-name
+ x-var))))))))))
diff --git a/test-suite/tests/tree-il-to-cps.test
b/test-suite/tests/tree-il-to-cps.test
new file mode 100644
index 0000000..c465dc0
--- /dev/null
+++ b/test-suite/tests/tree-il-to-cps.test
@@ -0,0 +1,135 @@
+(use-modules
+ (test-suite lib)
+ (language cps compile-rtl)
+ (language cps cps-isomorphic)
+ (language cps))
+
+(pass-if "Constant expressions"
+ (cps-isomorphic?
+ (cps-compile '(lambda () 3) #:to 'cps)
+ (parse-cps
+ '(lambda () #f
+ (letval (x) ((const 3))
+ (call return #f (x)))))))
+
+(pass-if "lexical-ref"
+ (cps-isomorphic?
+ (cps-compile '(lambda (x) x) #:to 'cps)
+ (parse-cps
+ '(lambda (x) #f
+ (letval (x-var) ((var x))
+ (call (primitive ref) return (x-var)))))))
+
+(pass-if "lexical-set"
+ (cps-isomorphic?
+ (cps-compile '(lambda (x y) (set! x y)) #:to 'cps)
+ (parse-cps
+ '(lambda (x y) #f
+ (letval (x-var y-var)
+ ((var x) (var y))
+ (letcont (setk) ((lambda (y-val) #f
+ (call (primitive set)
+ return
+ (x-var y-val))))
+ (call (primitive ref) setk (y-var))))))))
+
+(pass-if "module-ref"
+ (cps-isomorphic?
+ (cps-compile '(lambda () (@ (mod) x)) #:to 'cps)
+ (parse-cps
+ '(lambda () #f
+ (letval (x-var) ((module-var (mod) x #t))
+ (call (primitive ref) return (x-var)))))))
+
+(pass-if "module-set"
+ (cps-isomorphic?
+ (cps-compile '(lambda (y) (set! (@ (mod) x) y)) #:to 'cps)
+ (parse-cps
+ '(lambda (y) #f
+ (letval (y-var) ((var y))
+ (letcont (refk) ((lambda (y-val) #f
+ (letval (x-var) ((module-var (mod) x #t))
+ (call (primitive set) return (x-var y-val)))))
+ (call (primitive ref) refk (y-var))))))))
+
+(pass-if "toplevel-ref"
+ (cps-isomorphic?
+ (cps-compile '(lambda () x) #:to 'cps)
+ (parse-cps
+ '(lambda () #f
+ (letval (x-var) ((module-var toplevel x #t))
+ (call (primitive ref) return (x-var)))))))
+
+(pass-if "toplevel-set"
+ (cps-isomorphic?
+ (cps-compile '(lambda (y) (set! x y)) #:to 'cps)
+ (parse-cps
+ '(lambda (y) #f
+ (letval (y-var) ((var y))
+ (letcont (refk) ((lambda (y-val) #f
+ (letval (x-var) ((module-var toplevel x #t))
+ (call (primitive set) return (x-var y-val)))))
+ (call (primitive ref) refk (y-var))))))))
+
+(pass-if "sequences"
+ (cps-isomorphic?
+ (cps-compile '(lambda (x y) (set! x y) x) #:to 'cps)
+ (parse-cps
+ '(lambda (x y) #f
+ (letval (x-var y-var) ((var x) (var y))
+ (letcont (seqk) ((lambda () rest
+ (call (primitive ref) return (x-var))))
+ (letcont (setk) ((lambda (y-val) #f
+ (call (primitive set) seqk (x-var y-val))))
+ (call (primitive ref) setk (y-var)))))))))
+
+(pass-if "let"
+ (cps-isomorphic?
+ (cps-compile '(lambda () (let ((x 3)) x)) #:to 'cps)
+ (parse-cps
+ '(lambda () #f
+ (letval (three) ((const 3))
+ (letval (x-var) ((var three))
+ (call (primitive ref) return (x-var))))))))
+
+(pass-if "if"
+ (cps-isomorphic?
+ (cps-compile '(lambda () (if 1 2 3)) #:to 'cps)
+ (parse-cps
+ '(lambda () #f
+ (letcont (con alt) ((lambda () #f
+ (letval (two) ((const 2))
+ (call return #f (two))))
+ (lambda () #f
+ (letval (three) ((const 3))
+ (call return #f (three)))))
+ (letval (one) ((const 1))
+ (if one con alt)))))))
+
+(pass-if "call"
+ (cps-isomorphic?
+ (cps-compile '(lambda (x y) (x y)) #:to 'cps)
+ (parse-cps
+ '(lambda (x y) #f
+ (letval (x-var y-var) ((var x) (var y))
+ (letcont
+ (proc-k)
+ ((lambda (proc) #f
+ (letcont
+ (arg-k)
+ ((lambda (arg) #f
+ (call proc return (arg))))
+ (call (primitive ref) arg-k (y-var)))))
+ (call (primitive ref) proc-k (x-var))))))))
+
+(pass-if "lambda"
+ (cps-isomorphic?
+ (cps-compile '(lambda () (lambda (x) x)) #:to 'cps)
+ (parse-cps
+ '(lambda () #f
+ (letrec
+ (func)
+ ((lambda (x) #f
+ (letval (x-var) ((var x))
+ (call (primitive ref) return (x-var)))))
+ (call return #f (func)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-120-g5a44ec4,
Noah Lavine <=