[Guile-commits] GNU Guile branch, master, updated. v2.1.0-215-g7ea00e2

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

The branch, master has been updated
       via  7ea00e230aa05bc143c12d20dbc1d865129875a9 (commit)
       via  d51fb1e67b8ac72b75e110f8f7337bf9c77f0ac2 (commit)
      from  b43e81dc6085f250a3520b69b6445dbc0896850c (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 7ea00e230aa05bc143c12d20dbc1d865129875a9
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 4 14:08:52 2013 +0200

    Contify functions in the scope of their continuation.
    
    * module/language/cps/contification.scm (contify): Fix to contify
      functions in the scope of their continuation.

commit d51fb1e67b8ac72b75e110f8f7337bf9c77f0ac2
Author: Andy Wingo <address@hidden>
Date:   Fri Oct 4 10:47:55 2013 +0200

    dfg: variable-free-in?, add variable-bound-in?
    
    * module/language/cps/dfg.scm (variable-free-in?): Rename from
      variable-used-in?, to match CWCC language.
      (variable-bound-in?): New interface.
    
    * module/language/cps/contification.scm (contify): Adapt caller.  Add
      more comments.

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

Summary of changes:
 module/language/cps/contification.scm |  132 +++++++++++++++++++++------------
 module/language/cps/dfg.scm           |   14 +++-
 2 files changed, 96 insertions(+), 50 deletions(-)

diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index b1932dd..469cd28 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -42,7 +42,8 @@
   (let* ((dfg (compute-dfg fun))
          (cont-table (dfg-cont-table dfg))
          (call-substs '())
-         (cont-substs '()))
+         (cont-substs '())
+         (pending-contifications (make-hash-table)))
     (define (subst-call! sym arities body-ks)
       (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
     (define (subst-return! old-tail new-tail)
@@ -50,6 +51,24 @@
     (define (lookup-return-cont k)
       (or (assq-ref cont-substs k) k))
 
+    (define (add-pending-contifications! scope conts)
+      (for-each (match-lambda
+                 (($ $cont k)
+                  (lift-definition! k scope dfg)))
+                conts)
+      (hashq-set! pending-contifications scope
+                  (append conts
+                          (hashq-ref pending-contifications scope '()))))
+    (define (finish-pending-contifications call term-k)
+      (match (hashq-ref pending-contifications term-k)
+        (#f call)
+        ((cont ...)
+         ;; Catch any possible double-contification bug.
+         (hashq-set! pending-contifications term-k 'poison)
+         (build-cps-term
+           ($letk ,(map visit-cont cont)
+             ,call)))))
+
     (define (contify-call proc args)
       (and=> (assq-ref call-substs proc)
              (lambda (clauses)
@@ -80,6 +99,12 @@
                     (list sym) (list self) (list tail)
                     (list arities) (list bodies)))
 
+    ;; Given a set of mutually recursive functions bound to local
+    ;; variables SYMS, with self symbols SELFS, tail continuations
+    ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
+    ;; contify them if we can prove that they all return to the same
+    ;; continuation.  Returns a true value on success, and false
+    ;; otherwise.
     (define (contify-funs term-k syms selfs tails arities bodies)
       ;; Are the given args compatible with any of the arities?
       (define (applicable? proc args)
@@ -117,19 +142,26 @@
                                   ((eq? k k*) (visit-uses uses k))
                                   (else #f))))))))))
               (lambda (k)
-                ;; We have a common continuation, so we contify: mark
-                ;; all SYMs for replacement in calls, and mark the tail
-                ;; continuations for replacement by K.
-                (for-each (lambda (sym tail arities bodies)
-                            (for-each (cut lift-definition! <> term-k dfg)
-                                      bodies)
-                            (subst-call! sym arities bodies)
-                            (subst-return! tail k))
-                          syms tails arities bodies)
-                k))))
+                ;; We have a common continuation.  High fives!
+                ;;
+                ;; (1) Find the scope at which to contify.
+                (let ((scope (if (variable-bound-in? k term-k dfg)
+                                 term-k
+                                 (lookup-def k dfg))))
+                  ;; (2) Mark all SYMs for replacement in calls, and
+                  ;; mark the tail continuations for replacement by K.
+                  (for-each (lambda (sym tail arities bodies)
+                              (match bodies
+                                ((($ $cont body-k) ...)
+                                 (subst-call! sym arities body-k)))
+                              (subst-return! tail k))
+                            syms tails arities bodies)
+                  ;; (3) Mutate the DFG to reflect the new scope of the
+                  ;; continuations, and arrange for the continuations to
+                  ;; be spliced into their new scope.
+                  (add-pending-contifications! scope (concatenate bodies))
+                  k)))))
 
-    ;; This is a first cut at a contification algorithm.  It contifies
-    ;; non-recursive functions that only have positional arguments.
     (define (visit-fun term)
       (rewrite-cps-exp term
         (($ $fun meta free body)
@@ -152,9 +184,21 @@
       (match term
         (($ $letk conts body)
          ;; Visit the body first, so we visit depth-first.
-         (let ((body (visit-term body term-k)))
-           (build-cps-term
-             ($letk ,(map visit-cont conts) ,body))))
+         (let lp ((body (visit-term body term-k)))
+           ;; Because we attach contified functions on a particular
+           ;; term-k, and one term-k can correspond to an arbitrarily
+           ;; nested sequence of $letrec and $letk instances, normalize
+           ;; so that all continuations are bound by one $letk --
+           ;; guaranteeing that they are in the same scope.
+           (rewrite-cps-term body
+             (($ $letrec names syms funs body)
+              ($letrec names syms funs ,(lp body)))
+             (($ $letk conts* body)
+              ($letk ,(append conts* (map visit-cont conts))
+                ,body))
+             (body
+              ($letk ,(map visit-cont conts)
+                ,body)))))
         (($ $letrec names syms funs body)
          (define (split-components nsf)
            ;; FIXME: Compute strongly-connected components.  Currently
@@ -162,7 +206,7 @@
            ;; components, and lump everything else in the remaining
            ;; component.
            (define (recursive? k)
-             (or-map (cut variable-used-in? <> k dfg) syms))
+             (or-map (cut variable-free-in? <> k dfg) syms))
            (let lp ((nsf nsf) (rec '()))
              (match nsf
                (()
@@ -183,19 +227,14 @@
                      ($ $cont fun-k _
                         ($ $kentry self
                            ($ $cont tail-k _ ($ $ktail))
-                           (($ $cont _ _ ($ $kclause arity
-                                            (and body ($ $cont body-k))))
+                           (($ $cont _ _ ($ $kclause arity body))
                             ...))))
                   ...)
-                 (if (contify-funs term-k sym self tail-k arity body-k)
-                     (let ((body* (visit-components components)))
-                       (build-cps-term
-                         ($letk ,(map visit-cont (concatenate body))
-                           ,body*)))
-                     (let-gensyms (k)
-                       (build-cps-term
-                         ($letrec name sym (map visit-fun fun)
-                                  ,(visit-components components))))))))))
+                 (if (contify-funs term-k sym self tail-k arity body)
+                     (visit-components components)
+                     (build-cps-term
+                       ($letrec name sym (map visit-fun fun)
+                                ,(visit-components components)))))))))
          (visit-components (split-components (map list names syms funs))))
         (($ $continue k exp)
          (let ((k* (lookup-return-cont k)))
@@ -211,25 +250,24 @@
                      (build-cps-term ($continue k* ,exp))
                      (build-cps-term ($continue k* ($values vals)))))
                (_ ($continue k* ,exp))))
-           (match exp
-             (($ $fun meta free
-                 ($ $cont fun-k _
-                    ($ $kentry self
-                       ($ $cont tail-k _ ($ $ktail))
-                       (($ $cont _ _ ($ $kclause arity
-                                        (and body ($ $cont body-k))))
-                        ...))))
-              (if (and=> (bound-symbol k*)
-                         (lambda (sym)
-                           (contify-fun term-k sym self tail-k arity body-k)))
-                  (build-cps-term
-                    ($letk ,(map visit-cont body)
-                      ($continue k* ($values ()))))
-                  (default)))
-             (($ $call proc args)
-              (or (contify-call proc args)
-                  (default)))
-             (_ (default)))))))
+           (finish-pending-contifications
+            (match exp
+              (($ $fun meta free
+                  ($ $cont fun-k _
+                     ($ $kentry self
+                        ($ $cont tail-k _ ($ $ktail))
+                        (($ $cont _ _ ($ $kclause arity body)) ...))))
+               (if (and=> (bound-symbol k*)
+                          (lambda (sym)
+                            (contify-fun term-k sym self tail-k arity body)))
+                   (build-cps-term
+                     ($continue k* ($values ())))
+                   (default)))
+              (($ $call proc args)
+               (or (contify-call proc args)
+                   (default)))
+              (_ (default)))
+            term-k)))))
 
     (let ((fun (visit-fun fun)))
       (if (null? call-substs)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 0826451..8ef3613 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -54,7 +54,8 @@
             find-defining-expression
             find-constant-value
             lift-definition!
-            variable-used-in?
+            variable-bound-in?
+            variable-free-in?
             constant-needs-allocation?
             dead-after-def?
             dead-after-use?
@@ -341,11 +342,18 @@
              (lp body))
             (_ #t))))))))
 
-(define (variable-used-in? var parent-k dfg)
+(define (variable-bound-in? var k dfg)
+  (match dfg
+    (($ $dfg conts use-maps uplinks)
+     (match (lookup-use-map k use-maps)
+       (($ $use-map sym def uses)
+        (continuation-scope-contains? def k uplinks))))))
+
+(define (variable-free-in? var k dfg)
   (match dfg
     (($ $dfg conts use-maps uplinks)
      (or-map (lambda (use)
-               (continuation-scope-contains? parent-k use uplinks))
+               (continuation-scope-contains? k use uplinks))
              (match (lookup-use-map var use-maps)
                (($ $use-map sym def uses)
                 uses))))))


hooks/post-receive
-- 
GNU Guile