[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-188-g47c38e0

[Mark H Weaver]

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=47c38e022fd67c74a01eab7fbd09fb29530e1225

The branch, wip-cps-bis has been updated
       via  47c38e022fd67c74a01eab7fbd09fb29530e1225 (commit)
      from  204597a4fdd4e7c31103605e8cc4f0f64fdf846a (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 47c38e022fd67c74a01eab7fbd09fb29530e1225
Author: Mark H Weaver <address@hidden>
Date:   Thu Aug 15 19:24:14 2013 -0400

    RTL Compiler: Fix local boxes and propagated free variables.
    
    * module/language/cps/closure-conversion.scm (init-closure): Add
      arguments 'outer-self' and 'outer-bound'.  Convert free variable
      references used during initialization of the new closure.
      (cc): In two places, rename the inner 'self' variable, so that the
      outer 'self' will be available to pass to 'init-closure'.
    
    * module/language/tree-il/compile-cps.scm (convert): In 'box-bound-var',
      bind the correct name to the box.
    
    * test-suite/tests/rtl-compilation.test: Add tests.

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

Summary of changes:
 module/language/cps/closure-conversion.scm |   44 +++++++++++++++++----------
 module/language/tree-il/compile-cps.scm    |    2 +-
 test-suite/tests/rtl-compilation.test      |   11 ++++++-
 3 files changed, 39 insertions(+), 18 deletions(-)

diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index 14a7282..d62714f 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -72,17 +72,26 @@ values: the term and a list of additional free variables in 
the term."
                                             (lambda (syms)
                                               (k (cons sym syms)))))))))
   
-(define (init-closure src v free body)
-  "Initialize the free variables in a closure bound to @var{sym}, and
-continue with @var{body}."
+(define (init-closure src v free outer-self outer-bound body)
+  "Initialize the free variables @var{free} in a closure bound to
address@hidden, and continue with @var{body}.  @var{outer-self} must be the
+label of the outer procedure, where the initialization will be
+performed, and @var{outer-bound} is the list of bound variables there."
   (fold (lambda (free idx body)
           (let-gensyms (k k* idxsym)
             (build-cps-term
               ($letk ((k src ($kargs () () ,body)))
-                ($letk ((k* src ($kargs ('idx) (idxsym)
-                                  ($continue k
-                                    ($primcall 'free-set! (v idxsym free))))))
-                  ($continue k* ($const idx)))))))
+                ,(convert-free-var
+                  free outer-self outer-bound
+                  (lambda (free)
+                    (values
+                     (build-cps-term
+                       ($letk ((k* src ($kargs ('idx) (idxsym)
+                                         ($continue k
+                                           ($primcall 'free-set!
+                                                      (v idxsym free))))))
+                         ($continue k* ($const idx))))
+                     '())))))))
         body
         free
         (iota (length free))))
@@ -134,15 +143,17 @@ convert functions to flat closures."
                   (free free))
            (match in
              (() (values (bindings body) free))
-             (((name sym ($ $fun meta self () entries)) . in)
-              (receive (entries fun-free) (cc* entries self (list self))
+             (((name sym ($ $fun meta inner-self () entries)) . in)
+              (receive (entries fun-free)
+                  (cc* entries inner-self (list inner-self))
                 (lp in
                     (lambda (body)
                       (let-gensyms (k)
                         (build-cps-term
                           ($letk ((k #f ($kargs (name) (sym) ,(bindings 
body))))
-                            ($continue k ($fun meta self fun-free 
,entries))))))
-                    (init-closure #f sym fun-free body)
+                            ($continue k
+                              ($fun meta inner-self fun-free ,entries))))))
+                    (init-closure #f sym fun-free self bound body)
                     (union free (difference fun-free bound))))))))))
 
     (($ $continue k ($ $var sym))
@@ -157,21 +168,22 @@ convert functions to flat closures."
             ($ $prim)))
      (values exp '()))
 
-    (($ $continue k ($ $fun meta self () entries))
-     (receive (entries free) (cc* entries self (list self))
+    (($ $continue k ($ $fun meta inner-self () entries))
+     (receive (entries free) (cc* entries inner-self (list inner-self))
        (match free
          (()
-          (values (build-cps-term ($continue k ($fun meta self free ,entries)))
+          (values (build-cps-term
+                    ($continue k ($fun meta inner-self free ,entries)))
                   free))
          (else
           (values
            (let-gensyms (kinit v)
              (build-cps-term
                ($letk ((kinit #f ($kargs (v) (v)
-                                   ,(init-closure #f v free
+                                   ,(init-closure #f v free self bound
                                                   (build-cps-term
                                                     ($continue k ($var v)))))))
-                 ($continue kinit ($fun meta self free ,entries)))))
+                 ($continue kinit ($fun meta inner-self free ,entries)))))
            (difference free bound))))))
 
     (($ $continue k ($ $call proc args))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 236d46a..07b0790 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -213,7 +213,7 @@
       ((box #t)
        (let-gensyms (k)
          (build-cps-term
-           ($letk ((k #f ($kargs (name) (sym) ,body)))
+           ($letk ((k #f ($kargs (name) (box) ,body)))
              ($continue k ($primcall 'box (sym)))))))
       (else body)))
 
diff --git a/test-suite/tests/rtl-compilation.test 
b/test-suite/tests/rtl-compilation.test
index 778edbd..57af017 100644
--- a/test-suite/tests/rtl-compilation.test
+++ b/test-suite/tests/rtl-compilation.test
@@ -50,6 +50,12 @@
   (pass-if-equal 1
       ((run-rtl '(lambda (x) x)) 1))
 
+  (pass-if-equal 6
+      ((((run-rtl '(lambda (x)
+                     (lambda (y)
+                       (lambda (z)
+                         (+ x y z))))) 1) 2) 3))
+
   (pass-if-equal 1
       (run-rtl '(identity 1)))
 
@@ -90,4 +96,7 @@
                     pair)))
       (list (car pair)
             (cdr pair)
-            result))))
+            result)))
+
+  (pass-if-equal "mutable lexicals" 2
+    (run-rtl '(let ((n 1)) (set! n 2) n))))


hooks/post-receive
-- 
GNU Guile