[Guile-commits] GNU Guile branch, master, updated. v2.1.0-268-g8695854

[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=8695854a7d0795f6a0680bbdf1fc62f2894b45aa

The branch, master has been updated
       via  8695854a7d0795f6a0680bbdf1fc62f2894b45aa (commit)
       via  be0a8bb4f07c460fa182edb733df8ca37f4e0d46 (commit)
       via  8b2a96d0448c763f8b0431016dc388c84e8a7980 (commit)
      from  5db3e6bce42d902cb8e6ea53e9e950e47496ae59 (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 8695854a7d0795f6a0680bbdf1fc62f2894b45aa
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 22 22:31:26 2013 +0200

    Fix assembler for keyword args
    
    * module/system/vm/assembler.scm (begin-kw-arity, kw-prelude): Fix
      functions with keywords.

commit be0a8bb4f07c460fa182edb733df8ca37f4e0d46
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 22 22:30:54 2013 +0200

    CPS conversion doesn't automatically produce $values
    
    * module/language/tree-il/compile-cps.scm (convert): Don't convert
      values primcalls to $values, because we don't know that the
      continuation can accept that number of values.

commit 8b2a96d0448c763f8b0431016dc388c84e8a7980
Author: Andy Wingo <address@hidden>
Date:   Tue Oct 22 22:29:56 2013 +0200

    Contify returns via calls to "values"
    
    * module/language/cps/contification.scm: Returns from contified
      functions should primcall to 'values, as in general the return
      continuation is a multiple value context ($ktrunc or $ktail).  A later
      pass can elide the primcall if appropriate.

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

Summary of changes:
 module/language/cps/contification.scm   |  186 ++++++++++++++++---------------
 module/language/tree-il/compile-cps.scm |    4 +-
 module/system/vm/assembler.scm          |    6 +-
 3 files changed, 102 insertions(+), 94 deletions(-)

diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index d0aa510..00a5a57 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -79,6 +79,9 @@
     ;; continuation.  Returns a true value on success, and false
     ;; otherwise.
     (define (contify-funs term-k syms selfs tails arities bodies)
+      (define (unused? sym)
+        (null? (lookup-uses sym dfg)))
+
       ;; Are the given args compatible with any of the arities?
       (define (applicable? proc args)
         (or-map (match-lambda
@@ -97,62 +100,71 @@
                 k))
           (_ #f)))
 
-      (and
-       (and-map null? (map (cut lookup-uses <> dfg) selfs))
-       (and=> (let visit-syms ((syms syms) (k #f))
-                (match syms
-                  (() k)
-                  ((sym . syms)
-                   (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
-                     (match uses
-                       (() (visit-syms syms k))
-                       ((use . uses)
-                        (and=> (call-target use sym)
-                               (lambda (k*)
-                                 (cond
-                                  ((memq k* tails) (visit-uses uses k))
-                                  ((not k) (visit-uses uses k*))
-                                  ((eq? k k*) (visit-uses uses k))
-                                  (else #f))))))))))
-              (lambda (k)
-                ;; We have a common continuation.  High fives!
-                ;;
-                ;; (1) Find the scope at which to contify.
-                (and=> 
-                 (if (continuation-bound-in? k term-k dfg)
-                     ;; The common continuation is in scope at the
-                     ;; function definition; yay.
-                     term-k
-                     ;; The common continuation is not in scope at the
-                     ;; function definition.  Boo.
-                     (let ((scope (lookup-block-scope k dfg)))
-                       (match (lookup-cont scope cont-table)
-                         ;; The common continuation was the tail of some
-                         ;; function inside the letrec body.
-                         (($ $kentry self tail clauses)
-                          (match clauses
-                            ;; If that function has just one clause,
-                            ;; contify into that clause.  Otherwise
-                            ;; bail.
-                            ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
-                             kargs)
-                            (_ #f)))
-                         ;; Otherwise the common continuation is in some
-                         ;; scope we can add to via $letk.
-                         (cont scope))))
-                 (lambda (scope)
-                   ;; (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) Arrange for the continuations to be spliced
-                   ;; into their new scope.
-                   (splice-conts! scope (concatenate bodies))
-                   k))))))
+      ;; If this set of functions is always called with one
+      ;; continuation, not counting tail calls between the functions,
+      ;; return that continuation.
+      (define (find-common-continuation)
+        (let visit-syms ((syms syms) (k #f))
+          (match syms
+            (() k)
+            ((sym . syms)
+             (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
+               (match uses
+                 (() (visit-syms syms k))
+                 ((use . uses)
+                  (and=> (call-target use sym)
+                         (lambda (k*)
+                           (cond
+                            ((memq k* tails) (visit-uses uses k))
+                            ((not k) (visit-uses uses k*))
+                            ((eq? k k*) (visit-uses uses k))
+                            (else #f)))))))))))
+
+      ;; Given that the functions are called with the common
+      ;; continuation K, determine the scope at which to contify the
+      ;; functions.  If K is in scope in the term, we go ahead and
+      ;; contify them there.  Otherwise the scope is inside the letrec
+      ;; body, and so choose the scope in which the continuation is
+      ;; defined, whose free variables are a superset of the free
+      ;; variables of the functions.
+      ;;
+      ;; FIXME: Does this choose the right scope for contified let-bound
+      ;; functions?
+      (define (find-contification-scope k)
+        (if (continuation-bound-in? k term-k dfg)
+            term-k
+            (let ((scope (lookup-block-scope k dfg)))
+              (match (lookup-cont scope cont-table)
+                ;; The common continuation was the tail of some function
+                ;; inside the letrec body.  If that function has just
+                ;; one clause, contify into that clause.  Otherwise
+                ;; bail.
+                (($ $kentry self tail clauses)
+                 (match clauses
+                   ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
+                    kargs)
+                   (_ #f)))
+                (_ scope)))))
+
+      ;; We are going to contify.  Mark all SYMs for replacement in
+      ;; calls, and mark the tail continuations for replacement by K.
+      ;; Arrange for the continuations to be spliced into SCOPE.
+      (define (enqueue-contification! k scope)
+        (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)
+        (splice-conts! scope (concatenate bodies))
+        #t)
+
+      ;; "Call me maybe"
+      (and (and-map unused? selfs)
+           (and=> (find-common-continuation)
+                  (lambda (k)
+                    (and=> (find-contification-scope k)
+                           (cut enqueue-contification! k <>))))))
 
     (define (visit-fun term)
       (match term
@@ -235,14 +247,26 @@
                  (((($ $arity req () #f () #f) . k) . clauses)
                   (if (= (length req) (length args))
                       (build-cps-term
-                        ($continue (lookup-return-cont k)
+                        ($continue k
                           ($values args)))
                       (lp clauses)))
                  ((_ . clauses) (lp clauses)))))))
-  (define (lookup-return-cont k)
-    (match (assq-ref cont-substs k)
-      (#f k)
-      (k (lookup-return-cont k))))
+  (define (continue k exp)
+    (define (lookup-return-cont k)
+      (match (assq-ref cont-substs k)
+        (#f k)
+        (k (lookup-return-cont k))))
+    (let ((k* (lookup-return-cont k)))
+      ;; We are contifying this return.  It must be a call or a
+      ;; primcall to values, return, or return-values.
+      (if (eq? k k*)
+          (build-cps-term ($continue k ,exp))
+          (rewrite-cps-term exp
+            (($ $primcall 'return (val))
+             ($continue k* ($primcall 'values (val))))
+            (($ $values vals)
+             ($continue k* ($primcall 'values vals)))
+            (_ ($continue k* ,exp))))))
   (define (splice-continuations term-k term)
     (match (hashq-ref cont-splices term-k)
       (#f term)
@@ -263,10 +287,9 @@
        ($fun meta free ,(visit-cont body)))))
   (define (visit-cont cont)
     (rewrite-cps-cont cont
-      (($ $cont sym src
-          ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
-             body))
-       (sym src ($kargs () () ,(visit-term body sym))))
+      (($ $cont (and k (? (cut memq <> fun-elisions))) src
+          ($ $kargs (_) (_) body))
+       (k src ($kargs () () ,(visit-term body k))))
       (($ $cont sym src ($ $kargs names syms body))
        (sym src ($kargs names syms ,(visit-term body sym))))
       (($ $cont sym src ($ $kentry self tail clauses))
@@ -304,29 +327,16 @@
       (($ $continue k exp)
        (splice-continuations
         term-k
-        (let ((k* (lookup-return-cont k)))
-          (define (default)
-            (rewrite-cps-term exp
-              (($ $fun) ($continue k* ,(visit-fun exp)))
-              (($ $primcall 'return (val))
-               ,(if (eq? k k*)
-                    (build-cps-term ($continue k* ,exp))
-                    (build-cps-term ($continue k* ($values (val))))))
-              (($ $primcall 'return-values vals)
-               ,(if (eq? k k*)
-                    (build-cps-term ($continue k* ,exp))
-                    (build-cps-term ($continue k* ($values vals)))))
-              (_ ($continue k* ,exp))))
-          (match exp
-            (($ $fun)
-             (if (memq k fun-elisions)
-                 (build-cps-term
-                   ($continue k* ($values ())))
-                 (default)))
-            (($ $call proc args)
-             (or (contify-call proc args)
-                 (default)))
-            (_ (default))))))))
+        (match exp
+          (($ $fun)
+           (if (memq k fun-elisions)
+               (build-cps-term
+                 ($continue k ($values ())))
+               (continue k (visit-fun exp))))
+          (($ $call proc args)
+           (or (contify-call proc args)
+               (continue k exp)))
+          (_ (continue k exp)))))))
   (visit-fun fun))
 
 (define (contify fun)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 707e08b..6202e12 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -347,9 +347,7 @@
                      k subst)
             (convert-args args
               (lambda (args)
-                (if (eq? name 'values)
-                    (build-cps-term ($continue k ($values args)))
-                    (build-cps-term ($continue k ($primcall name args))))))))))
+                (build-cps-term ($continue k ($primcall name args)))))))))
 
     ;; Prompts with inline handlers.
     (($ <prompt> src escape-only? tag body
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 6b0ac48..f43acb3 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -659,8 +659,8 @@ returned instead."
   (assert-match req ((? symbol?) ...) "list of symbols")
   (assert-match opt ((? symbol?) ...) "list of symbols")
   (assert-match rest (or #f (? symbol?)) "#f or symbol")
-  (assert-match kw-indices (((? symbol?) . (? integer?)) ...)
-                "alist of symbol -> integer")
+  (assert-match kw-indices (((? keyword?) . (? integer?)) ...)
+                "alist of keyword -> integer")
   (assert-match allow-other-keys? (? boolean?) "boolean")
   (assert-match nlocals (? integer?) "integer")
   (assert-match alternate (or #f (? symbol?)) "#f or symbol")
@@ -726,7 +726,7 @@ returned instead."
                       (pack-flags allow-other-keys? rest?)
                       (+ nreq nopt)
                       ntotal
-                      kw-indices)
+                      (intern-constant asm kw-indices))
     (emit-alloc-frame asm nlocals)))
 
 (define-macro-assembler (label asm sym)


hooks/post-receive
-- 
GNU Guile