[Guile-commits] GNU Guile branch, wip-cps-bis, updated. v2.1.0-161-gd9f60f3

[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=d9f60f3ff9b5aa5df75c84b11c87acbd18b35488

The branch, wip-cps-bis has been updated
       via  d9f60f3ff9b5aa5df75c84b11c87acbd18b35488 (commit)
      from  242ba83c88699c72b1ac5455140d3385b404b596 (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 d9f60f3ff9b5aa5df75c84b11c87acbd18b35488
Author: Mark H Weaver <address@hidden>
Date:   Tue Aug 13 17:17:02 2013 -0400

    Progress toward working closures.
    
    * module/language/cps/closure-conversion.scm (init-closure):
      Add the missing index field to 'free-set!' primcalls.
      (convert-to-indices): New procedure.
      (convert-closures): Use 'convert-to-indices'.
    
    * module/language/cps/compile-rtl.scm (emit-rtl-sequence): Handle
      generation of 'free-ref' and 'free-set!' instructions.

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

Summary of changes:
 module/language/cps/closure-conversion.scm |   62 +++++++++++++++++++++++++--
 module/language/cps/compile-rtl.scm        |    6 +++
 2 files changed, 63 insertions(+), 5 deletions(-)

diff --git a/module/language/cps/closure-conversion.scm 
b/module/language/cps/closure-conversion.scm
index a20026d..24a5b4f 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -87,13 +87,19 @@ values: the term and a list of additional free variables in 
the term."
 (define (init-closure src v free body)
   "Initialize the free variables in a closure bound to @var{sym}, and
 continue with @var{body}."
-  (fold (lambda (free body)
-          (let ((k (gensym "k")))
+  (fold (lambda (free idx body)
+          (let ((k (gensym "k"))
+                (k* (gensym "k*"))
+                (idxsym (gensym "idx")))
             (make-$let1k
              (make-$cont src k (make-$kargs '() '() body))
-             (make-$continue k (make-$primcall 'free-set! (list v free))))))
+             (make-$let1v
+              src k* 'idx idxsym
+              (make-$continue k (make-$primcall 'free-set! (list v idxsym 
free)))
+              (make-$continue k* (make-$const idx))))))
         body
-        free))
+        free
+        (iota (length free))))
 
 ;; Closure conversion.
 (define (cc exp self bound)
@@ -206,6 +212,52 @@ convert functions to flat closures."
 
     (_ (error "what" exp))))
 
+;; Convert the slot arguments of 'free-ref' primcalls from symbols to
+;; indices.
+(define (convert-to-indices exp)
+  (let lpfree ((exp exp) (free '()))
+    (let lp ((exp exp))
+      (match exp
+        (($ $letk conts body)
+         (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)))))
+        ;; Other kinds of continuations don't
+        ;; bind values and don't have bodies.
+        (($ $cont) exp)
+        (($ $kif kt kf) exp)
+        (($ $ktrunc arity k) exp)
+        (($ $letrec names syms funs body)
+         (make-$letrec names syms (map lp funs) (lp body)))
+        (($ $call proc args) exp)
+        (($ $continue k ($ $primcall 'free-ref args))
+         (match args
+           ((closure sym)
+            (let ((idx (let lp ((i 0) (f free))
+                         (cond ((null? f)
+                                ((error "convert-to-indices: free variable not 
found!"
+                                        sym free exp)))
+                               ((eq? sym (car f))
+                                i)
+                               (else (lp (+ i 1) (cdr f))))))
+                  (idxsym (gensym "idx"))
+                  (k* (gensym "k")))
+              (make-$let1v #f k* 'idx idxsym
+                           (make-$continue k (make-$primcall
+                                              'free-ref (list closure idxsym)))
+                           (make-$continue k* (make-$const idx)))))))
+        (($ $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))))
+        (($ $values args) exp)
+        (_ ((error "convert-to-indices: unhandled case")))))))
+
 (define (convert-closures exp)
   "Convert free reference in @var{exp} to primcalls to @code{free-ref},
 and allocate and initialize flat closures."
@@ -214,4 +266,4 @@ and allocate and initialize flat closures."
      (receive (body free) (cc body #f '())
        (unless (null? free)
          (error "Expected no free vars in toplevel thunk" exp))
-       (make-$fun meta self '() body)))))
+       (make-$fun meta self '() (convert-to-indices body))))))
diff --git a/module/language/cps/compile-rtl.scm 
b/module/language/cps/compile-rtl.scm
index 11f6164..98a72e8 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -194,6 +194,9 @@
                                        ,(constant public?) ,(constant 
bound?))))
             (($ $primcall 'resolve (name bound?))
              (emit `(resolve ,dst ,(constant bound?) ,(slot name))))
+            (($ $primcall 'free-ref (closure idx))
+             ;; XXX FIXME prevent IDX from being needlessly loaded into a 
register!
+             (emit `(free-ref ,dst ,(slot closure) ,(constant idx))))
             (($ $primcall name args)
              (let ((name (or (assq-ref *rtl-instruction-aliases* name)
                              name)))
@@ -220,6 +223,9 @@
         (match exp
           (($ $primcall 'cache-current-module! (sym scope))
            (emit `(cache-current-module! ,(slot sym) ,(constant scope))))
+          (($ $primcall 'free-set! (closure idx value))
+           ;; XXX FIXME prevent IDX from being needlessly loaded into a 
register!
+           (emit `(free-set! ,(slot closure) ,(slot value) ,(constant idx))))
           (($ $primcall name args)
            (emit `(primcall/seq ,name ,@args)))
           (($ $values ()) #f))


hooks/post-receive
-- 
GNU Guile