[Guile-commits] GNU Guile branch, wip-rtl-cps, updated. v2.1.0-163-g6abdb93

[Noah Lavine]

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=6abdb93204b26340d299c4091ff8d137f4d7bcb9

The branch, wip-rtl-cps has been updated
       via  6abdb93204b26340d299c4091ff8d137f4d7bcb9 (commit)
       via  4343aa4954bcf46983b7b47a2940615aef15a4cd (commit)
      from  5969a23c88c662f4f555d268303914880353f467 (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 6abdb93204b26340d299c4091ff8d137f4d7bcb9
Author: Noah Lavine <address@hidden>
Date:   Thu Jan 24 23:25:53 2013 -0500

    Begin Tree-IL->CPS Compiler
    
    * module/language/tree-il/compile-cps.scm: add (partial) Tree-IL->CPS
      compiler.
    * test-suite/tests/cps.test: test Tree-IL->CPS compiler by using it in
      CPS tests.

commit 4343aa4954bcf46983b7b47a2940615aef15a4cd
Author: Noah Lavine <address@hidden>
Date:   Thu Jan 24 23:23:03 2013 -0500

    Simplify CPS If
    
    * module/language/cps.scm: simplify CPS `if'.
    * module/language/cps/compile-rtl.scm: compile simpler `if'.
    * test-suite/tests/cps.test: test new, simpler form of `if'.

-----------------------------------------------------------------------

Summary of changes:
 module/language/cps.scm                 |   39 ++++++++-------
 module/language/cps/compile-rtl.scm     |   29 ++++--------
 module/language/tree-il/compile-cps.scm |   81 +++++++++++++++++++++++++++++++
 test-suite/tests/cps.test               |   42 ++++++++--------
 4 files changed, 132 insertions(+), 59 deletions(-)
 create mode 100644 module/language/tree-il/compile-cps.scm

diff --git a/module/language/cps.scm b/module/language/cps.scm
index ea57cf3..1ddbda4 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -35,12 +35,17 @@
 ;;  forms represent some subset of the control flow graph in two parts,
 ;;  and control only flows one direction between the parts.
 
-;;  3) every lexical variable gets a unique name, and if it is set!, the
-;;  new value gets a new name! therefore the variable names track
-;;  uniqueness in the eq? sense. also, since every variable gets a
-;;  unique name, we don't have to bother with environment structures
-;;  just to store properties - we just use the variable names as keys to
-;;  a hash table and know that they won't collide.
+;; Interestingly enough, we don't require that all continuations be
+;; described by functions, even though that's the origin of CPS. the
+;; reason is that we can't really convert all continuation captures to
+;; function calls unless we can look inside every function (both Scheme
+;; and C), see whether it captures its continuation, and rewrite it so
+;; that it works with a function instead (or alternatively use a calling
+;; convention where continuations are always reified, but that seems
+;; terrible). we might be able to rewrite certain continuations or
+;; delimited continuations as functions, but we can't assume we'll get
+;; them all. so we really are using the continuations as a way to
+;; represent control flow, and not as real continuations!
 
 (define-type <cps>
   ;; <letval> actually handles multiple constant values, because why
@@ -78,12 +83,16 @@
   ;; is a symbol.
   (<primitive> name)
   ;; the 'if' form is like a Scheme 'if', except that the test must be a
-  ;; lexical variable. the consequent and alternate can be any CPS
-  ;; forms.
+  ;; lexical variable, and the consequent and alternate must be names of
+  ;; continuations. the if will jump to whichever continuation is
+  ;; appropriate. in the future, I'd like to make 'if a primitive
+  ;; procedure and not a special form. that requires having a way for
+  ;; primitive procedures to be inlined, but otherwise might be all
+  ;; right.
   (<if> test consequent alternate)
-  ;; right now we are missing the 'let' from Kennedy's paper. That is
-  ;; used to compose record constructors and field accessors, but we are
-  ;; not attempting to do that yet.
+  ;; we don't have the 'let' form from Kennedy's paper yet. We
+  ;; eventually want to use something like it to compose record
+  ;; constructors and accessors, and also describe mutable variables
   )
 
 (define (parse-cps tree)
@@ -107,9 +116,7 @@
     (('primitive name)
      (make-primitive name))
     (('if test consequent alternate)
-     (make-if test
-              (parse-cps consequent)
-              (parse-cps alternate)))
+     (make-if test consequent alternate))
     (_ (error "couldn't parse CPS" tree))))
 
 (define (unparse-cps cps)
@@ -133,7 +140,5 @@
     (($ <primitive> name)
      (list 'primitive name))
     (($ <if> test consequent alternate)
-     (list 'if test
-           (unparse-cps consequent)
-           (unparse-cps alternate)))
+     (list 'if test consequent alternate))
     (_ (error "couldn't unparse CPS" cps))))
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 981a6d7..bfb8c2e 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -121,15 +121,10 @@
                (map alloc-func funcs)
                (visit body counter)))))
 
-      ;; for an if, we need labels for the consequent and alternate (so
-      ;; we can branch to one or the other). the register allocations
-      ;; for them can overlap, since only one will ever be used, but we
-      ;; need to save enough space for whichever is bigger.
+      ;; an if has no interesting content, so we don't need to do
+      ;; anything here.
       ((<if> test consequent alternate)
-       (set! (label consequent) (next-label!))
-       (set! (label alternate) (next-label!))
-       (max (visit consequent counter)
-            (visit alternate counter)))))
+       counter)))
 
   (visit cps 0))
 
@@ -176,11 +171,7 @@
            ;; this is sort of an ugly way to show the labels of the
            ;; if-branches, but I don't have a better one right now.
            ((<if> test consequent alternate)
-            `(if ,test
-                 (label ,(label consequent))
-                 ,(with-alloc consequent)
-                 (label ,(label alternate))
-                 ,(with-alloc alternate)))))))
+            `(if ,test ,consequent ,alternate))))))
 
 (define (show-alloc! cps)
   (allocate-registers-and-labels! cps)
@@ -337,15 +328,13 @@
                 (br ,(label cont))    ;; MVRA
                 (br ,(label cont)))) ;; RA
             (error "We don't know how to compile" cps)))
-       ;; the second argument to br-if-true is either 0 or 1. if it is
-       ;; one, the instruction acts like br-if-false.
+       ;; consequent and alternate should both be continuations with no
+       ;; arguments, so we call them by just jumping to them.
        (($ <if> test consequent alternate)
+        ;; the second argument to br-if-true is either 0 or 1. if it is
+        ;; one, the instruction acts like br-if-false.
         `((br-if-true ,(register test) 1 ,(label alternate))
-          ,@(visit consequent)
-          (br ,(label consequent))
-          (label ,(label alternate))
-          ,@(visit alternate)
-          (label ,(label consequent))))
+          (br ,(label consequent))))
        (($ <letval> names vals body)
         `(,@(append-map!
              (lambda (name val)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
new file mode 100644
index 0000000..7637198
--- /dev/null
+++ b/module/language/tree-il/compile-cps.scm
@@ -0,0 +1,81 @@
+(define-module (language tree-il compile-cps)
+  #:use-module (language tree-il)
+  #:use-module ((language cps)
+                #:renamer (symbol-prefix-proc 'cps-))
+  #:use-module (ice-9 match)
+  #:export (tree-il->cps))
+
+
+;; k is the continuation
+(define (tree-il->cps tree)
+  ;; with-value-name first generates some CPS that finds the value of
+  ;; tree, and then calls 'gen-k' to generate more CPS code - but
+  ;; 'gen-k' is called with a name which can reference the value of
+  ;; tree. the real point is to abstract out the idea of *not*
+  ;; generating extra continuations for lexical variable references. we
+  ;; could always optimize them out later, but it seems easier to just
+  ;; not make them in the first place.
+  (define (with-value-name gen-k tree)
+    (if (lexical-ref? tree)
+        (gen-k (lexical-ref-gensym tree))
+        (let ((con (gensym "con-"))
+              (val (gensym "val-")))
+          (cps-make-letcont
+           (list con)
+           (list (cps-make-lambda (list val) (gen-k val)))
+           (visit con tree)))))
+
+  ;; like with-value-names, but takes a list of trees, and applies gen-k
+  ;; to the corresponding list of values. the generated code evaluates
+  ;; the list of values in the same order as they appear in the list.
+  (define (with-value-names gen-k trees)
+    (let iter ((trees trees)
+               (names '())) ;; names are accumulated in reverse order
+      (if (null? trees)
+          (apply gen-k (reverse names))
+          (with-value-name
+           (lambda (name) (iter (cdr trees) (cons name names)))
+           (car trees)))))
+  
+  ;; visit returns a CPS version of tree which ends by calling
+  ;; continuation k
+  (define (visit k tree)
+    (match tree
+      ;; note: 1. we only support lambdas with one case right now, and
+      ;; totally ignore optional, rest and keyword arguments. 2. we only
+      ;; support lambda forms as the outermost part of the Tree-IL.
+      (($ <lambda> src meta
+          ($ <lambda-case> src req opt rest kw inits gensyms body alternate))
+       (cps-make-lambda gensyms
+         (visit 'return body)))
+      (($ <call> src proc args)
+       (with-value-names
+        (lambda (proc . args)
+          (cps-make-call proc k args))
+        (cons proc args)))
+      (($ <conditional> src test consequent alternate)
+       ;; the control flow for an if looks like this:
+       ;;  test --> if ---> then ---> con
+       ;;               \-> else  -/       
+       (let ((con (gensym "con-"))
+             (alt (gensym "con-")))
+         (cps-make-letcont
+          (list con alt)
+          (list
+           (cps-make-lambda '() (visit k consequent))
+           (cps-make-lambda '() (visit k alternate)))
+          (with-value-name
+           (lambda (test-val)
+             (cps-make-if test-val con alt))
+           test))))
+      (($ <lexical-ref> src name gensym)
+       (cps-make-call k #f (list gensym)))
+      (($ <const> src exp)
+       (let ((v (gensym "val-")))
+         (cps-make-letval
+          (list v)
+          (list exp)
+          (cps-make-call k #f (list v)))))
+      (x (error "Unrecognized tree-il:" x))))
+
+  (visit 'return tree))
diff --git a/test-suite/tests/cps.test b/test-suite/tests/cps.test
index a25ead9..bb84f36 100644
--- a/test-suite/tests/cps.test
+++ b/test-suite/tests/cps.test
@@ -1,52 +1,50 @@
 (use-modules
  (test-suite lib)
  (language cps)
- (language cps compile-rtl))
+ (language cps compile-rtl)
+ (language tree-il compile-cps))
 
+;; a convenient way to write literal CPS code
 (define-syntax-rule (cps x)
   (cps->program (parse-cps 'x)))
 
-;; (lambda () 3)
+;; by-cps: compile a procedure, but by way of CPS instead of the normal
+;; compiler chain
+(define (by-cps x)
+  (cps->program (tree-il->cps (compile x #:to 'tree-il))))
+
 (pass-if "return-three"
   (= 3
-     ((cps (lambda ()
-             (letval (val) (3)
-               (call return #f (val))))))))
+     ((by-cps 3))))
 
 (define (return-three) 3)
 
-;; (lambda (x) (x))
 (pass-if "call-arg"
   (= 3
-     ((cps (lambda (x) (call x return ())))
+     ((by-cps '(lambda (x) (x)))
       return-three)))
 
 (define (add-two x) (+ x 2))
 
-;; (lambda (x y) (x (y)))
 (pass-if "single-value compose"
   (= 5
-     ((cps (lambda (x y)
-             (letcont (c1)
-               ((lambda (r) (call x return (r))))
-               (call y c1 ()))))
+     ((by-cps '(lambda (x y) (x (y))))
       add-two
       return-three)))
 
-;; (lambda (k x) (k x)) <= (lambda (x) x)
 (pass-if "identity function"
   (= 3
-     ((cps (lambda (x) (call return #f (x))))
+     ((by-cps '(lambda (x) x))
       3)))
 
-;; (lambda (x) (if x 1 2))
-(pass-if "if"
-  (= 1
-     ((cps (lambda (x)
-             (letval (one two) (1 2)
-               (if x (call return #f (one))
-                   (call return #f (two))))))
-      #t)))
+(define if-func
+  (by-cps '(lambda (x) (if x 1 2))))
+
+(pass-if "if true"
+  (= 1 (if-func #t)))
+
+(pass-if "if false"
+  (= 2 (if-func #f)))
 
 ;; (lambda () (+ 2 3))
 (pass-if "+"


hooks/post-receive
-- 
GNU Guile