[Guile-commits] GNU Guile branch, master, updated. v2.1.0-868-g48e65b4

[Andy Wingo]

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=48e65b446822bffec9aa874bd39ca25ac4f29589

The branch, master has been updated
       via  48e65b446822bffec9aa874bd39ca25ac4f29589 (commit)
       via  408da790153b2c9620df5169e976e05d3647b995 (commit)
      from  ce1dbe8c1bc3f1d37978d2ca1d5949b03514a5e3 (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 48e65b446822bffec9aa874bd39ca25ac4f29589
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 2 15:58:06 2014 +0200

    Refactor toplevel scope name generation in compile-cps
    
    * module/language/tree-il/compile-cps.scm (scope-counter, fresh-scope-id):
      (toplevel-box, capture-toplevel-scope, convert, cps-convert/thunk):
      Refactor to avoid abusing the var counter to generate scope
      identifiers.

commit 408da790153b2c9620df5169e976e05d3647b995
Author: Andy Wingo <address@hidden>
Date:   Wed Apr 2 15:48:13 2014 +0200

    compute-max-label-and-var takes letrec vars into account.
    
    * module/language/cps.scm (compute-max-label-and-var): Fix to take
      letrec vars into account.

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

Summary of changes:
 module/language/cps.scm                 |    9 +++++-
 module/language/tree-il/compile-cps.scm |   45 +++++++++++++++++++-----------
 2 files changed, 35 insertions(+), 19 deletions(-)

diff --git a/module/language/cps.scm b/module/language/cps.scm
index c1bb304..90f38a4 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -508,8 +508,13 @@
    (lambda (label cont max-label max-var)
      (values (max label max-label)
              (match cont
-               (($ $kargs names vars)
-                (fold max max-var vars))
+               (($ $kargs names vars body)
+                (let lp ((body body) (max-var (fold max max-var vars)))
+                  (match body
+                    (($ $letk conts body) (lp body max-var))
+                    (($ $letrec names vars funs body)
+                     (lp body (fold max max-var vars)))
+                    (_ max-var))))
                (($ $kentry self)
                 (max self max-var))
                (_ max-var))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 0c0085d..5e7e66f 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -75,6 +75,12 @@
 ;;; doesn't work for files auto-compiled for use with `load'.
 ;;;
 (define current-topbox-scope (make-parameter #f))
+(define scope-counter (make-parameter #f))
+
+(define (fresh-scope-id)
+  (let ((scope-id (scope-counter)))
+    (scope-counter (1+ scope-id))
+    scope-id))
 
 (define (toplevel-box src name bound? val-proc)
   (let-fresh (kbox) (name-sym bound?-sym box)
@@ -88,10 +94,10 @@
                 ($continue kbox src
                   ($primcall 'resolve
                              (name-sym bound?-sym)))))
-             (scope
+             (scope-id
               (let-fresh () (scope-sym)
                 (build-cps-term
-                  ($letconst (('scope scope-sym scope))
+                  ($letconst (('scope scope-sym scope-id))
                     ($continue kbox src
                       ($primcall 'cached-toplevel-box
                                  (scope-sym name-sym bound?-sym)))))))))))))
@@ -108,10 +114,10 @@
             ($primcall 'cached-module-box
                        (module-sym name-sym public?-sym bound?-sym))))))))
 
-(define (capture-toplevel-scope src scope k)
+(define (capture-toplevel-scope src scope-id k)
   (let-fresh (kmodule) (module scope-sym)
     (build-cps-term
-      ($letconst (('scope scope-sym scope))
+      ($letconst (('scope scope-sym scope-id))
         ($letk ((kmodule ($kargs ('module) (module)
                            ($continue k src
                              ($primcall 'cache-current-module!
@@ -294,12 +300,14 @@
                  ($fun fun-src meta '()
                        (kentry ($kentry self (ktail ($ktail))
                                  ,(convert-clauses body ktail)))))))
-           (let-fresh (kscope) (scope)
-             (build-cps-term
-               ($letk ((kscope ($kargs () ()
-                                 ,(parameterize ((current-topbox-scope scope))
-                                    (convert exp k subst)))))
-                 ,(capture-toplevel-scope fun-src scope kscope)))))))
+           (let ((scope-id (fresh-scope-id)))
+             (let-fresh (kscope) ()
+               (build-cps-term
+                 ($letk ((kscope
+                          ($kargs () ()
+                            ,(parameterize ((current-topbox-scope scope-id))
+                               (convert exp k subst)))))
+                   ,(capture-toplevel-scope fun-src scope-id kscope))))))))
 
     (($ <module-ref> src mod name public?)
      (module-box
@@ -517,12 +525,14 @@
                                 fun)))
                            funs)
                       ,(convert body k subst))))
-         (let-fresh (kscope) (scope)
-           (build-cps-term
-             ($letk ((kscope ($kargs () ()
-                               ,(parameterize ((current-topbox-scope scope))
-                                  (convert exp k subst)))))
-               ,(capture-toplevel-scope src scope kscope))))))
+         (let ((scope-id (fresh-scope-id)))
+           (let-fresh (kscope) ()
+             (build-cps-term
+               ($letk ((kscope
+                        ($kargs () ()
+                          ,(parameterize ((current-topbox-scope scope-id))
+                             (convert exp k subst)))))
+                 ,(capture-toplevel-scope src scope-id kscope)))))))
 
     (($ <let-values> src exp
         ($ <lambda-case> lsrc req #f rest #f () syms body #f))
@@ -589,7 +599,8 @@ integer."
 
 (define (cps-convert/thunk exp)
   (parameterize ((label-counter 0)
-                 (var-counter 0))
+                 (var-counter 0)
+                 (scope-counter 0))
     (let ((src (tree-il-src exp)))
       (let-fresh (kinit ktail kclause kbody) (init)
         (build-cps-exp


hooks/post-receive
-- 
GNU Guile