[Guile-commits] GNU Guile branch, master, updated. v2.1.0-27-gfb512ca

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

The branch, master has been updated
       via  fb512cac6ebebc1c31fdb3447fba0ac4b496237a (commit)
       via  c8d87b4745553e3e3dc26002f767ca2aab3a10ef (commit)
       via  aa980ce0dc09ae4928102c9b034dfdd684cd9fd6 (commit)
      from  7af81156754f8be7d7661879f7d0c13bb00e5728 (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 fb512cac6ebebc1c31fdb3447fba0ac4b496237a
Author: Andy Wingo <address@hidden>
Date:   Wed May 7 15:28:50 2014 +0200

    Add dump-dfg pretty-printer
    
    * module/language/cps/dfg.scm (dump-dfg): New pretty-printer.  Under
      construction.

commit c8d87b4745553e3e3dc26002f767ca2aab3a10ef
Author: Andy Wingo <address@hidden>
Date:   Wed May 7 15:28:12 2014 +0200

    Synthetic definitions take advantage of CSE'd vars
    
    * module/language/cps/cse.scm (compute-available-expressions):
      Simplify initialization.
      (compute-equivalent-subexpressions): When synthesizing definitions,
      use substed vars.  Add synthetic definitions after processing an
      expression, to take advantage of the substed vars.

commit aa980ce0dc09ae4928102c9b034dfdd684cd9fd6
Author: Andy Wingo <address@hidden>
Date:   Wed May 7 15:25:13 2014 +0200

    Fix thinko in synthesize-definition-effects!
    
    * module/language/cps/effects-analysis.scm (synthesize-definition-effects!):
      Fix a boneheaded thinko that caused all primcalls to be marked as
      causing car, cdr, vector, struct, and box effects.

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

Summary of changes:
 module/language/cps/cse.scm              |   31 +++++++++--------
 module/language/cps/dfg.scm              |   53 ++++++++++++++++++++++++++++++
 module/language/cps/effects-analysis.scm |    4 ++-
 3 files changed, 72 insertions(+), 16 deletions(-)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 52c22af..e3b5ff2 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -62,11 +62,9 @@ index corresponds to MIN-LABEL, and so on."
 
     (let lp ((n 0))
       (when (< n label-count)
-        (let ((in (make-bitvector label-count #f))
-              (out (make-bitvector label-count #f)))
-          (vector-set! avail-in n in)
-          (vector-set! avail-out n out)
-          (lp (1+ n)))))
+        (vector-set! avail-in n (make-bitvector label-count #f))
+        (vector-set! avail-out n (make-bitvector label-count #f))
+        (lp (1+ n))))
 
     (let ((tmp (make-bitvector label-count #f)))
       (define (bitvector-copy! dst src)
@@ -365,14 +363,14 @@ be that both true and false proofs are available."
             (('primcall 'box val)
              (match defs
                ((box)
-                (add-def! `(primcall box-ref ,box) val))))
+                (add-def! `(primcall box-ref ,(subst-var box)) val))))
             (('primcall 'box-set! box val)
              (add-def! `(primcall box-ref ,box) val))
             (('primcall 'cons car cdr)
              (match defs
                ((pair)
-                (add-def! `(primcall car ,pair) car)
-                (add-def! `(primcall cdr ,pair) cdr))))
+                (add-def! `(primcall car ,(subst-var pair)) car)
+                (add-def! `(primcall cdr ,(subst-var pair)) cdr))))
             (('primcall 'set-car! pair car)
              (add-def! `(primcall car ,pair) car))
             (('primcall 'set-cdr! pair cdr)
@@ -380,7 +378,7 @@ be that both true and false proofs are available."
             (('primcall (or 'make-vector 'make-vector/immediate) len fill)
              (match defs
                ((vec)
-                (add-def! `(primcall vector-length ,vec) len))))
+                (add-def! `(primcall vector-length ,(subst-var vec)) len))))
             (('primcall 'vector-set! vec idx val)
              (add-def! `(primcall vector-ref ,vec ,idx) val))
             (('primcall 'vector-set!/immediate vec idx val)
@@ -389,7 +387,8 @@ be that both true and false proofs are available."
                         vtable size)
              (match defs
                ((struct)
-                (add-def! `(primcall struct-vtable ,struct) vtable))))
+                (add-def! `(primcall struct-vtable ,(subst-var struct))
+                          vtable))))
             (('primcall 'struct-set! struct n val)
              (add-def! `(primcall struct-ref ,struct ,n) val))
             (('primcall 'struct-set!/immediate struct n val)
@@ -414,10 +413,6 @@ be that both true and false proofs are available."
                        (equiv (hash-ref equiv-set exp-key '()))
                        (lidx (label->idx label))
                        (avail (vector-ref avail lidx)))
-                  ;; If this expression defines auxiliary definitions,
-                  ;; as `cons' does for the results of `car' and `cdr',
-                  ;; define those.
-                  (add-auxiliary-definitions! label exp-key)
                   (let lp ((candidates equiv))
                     (match candidates
                       (()
@@ -452,7 +447,13 @@ be that both true and false proofs are available."
                             (lambda (var subst-var)
                               (vector-set! var-substs (var->idx var) 
subst-var))
                             (vector-ref defs lidx)
-                            vars)))))))))))
+                            vars)))))))
+                  ;; If this expression defines auxiliary definitions,
+                  ;; as `cons' does for the results of `car' and `cdr',
+                  ;; define those.  Do so after finding equivalent
+                  ;; expressions, so that we can take advantage of
+                  ;; subst'd output vars.
+                  (add-auxiliary-definitions! label exp-key)))))
             (_ #f))
           (lp (1+ label))))
       (values (compute-dom-edges idoms min-label)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index e48fe5e..7fc8ed4 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -36,6 +36,7 @@
 
 (define-module (language cps dfg)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -897,6 +898,58 @@ body continuation in the prompt."
                   min-label max-label label-count
                   min-var max-var var-count)))))
 
+(define* (dump-dfg dfg #:optional (port (current-output-port)))
+  (let ((min-label (dfg-min-label dfg))
+        (min-var (dfg-min-var dfg)))
+    (define (label->idx label) (- label min-label))
+    (define (idx->label idx) (+ idx min-label))
+    (define (var->idx var) (- var min-var))
+    (define (idx->var idx) (+ idx min-var))
+
+    (let lp ((label (dfg-min-label dfg)))
+      (when (< label (dfg-max-label dfg))
+        (let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label))))
+          (when cont
+            (unless (equal? (lookup-predecessors label dfg) (list (1- label)))
+              (newline port))
+            (format port "k~a:~8t" label)
+            (match cont
+              (($ $kif kt kf)
+               (format port "$kif k~a k~a\n" kt kf))
+              (($ $kreceive arity k)
+               (format port "$kreceive ~a k~a\n" arity k))
+              (($ $kfun src meta self tail clause)
+               (format port "$kfun ~a ~a v~a\n" src meta self))
+              (($ $ktail)
+               (format port "$ktail\n"))
+              (($ $kclause arity ($ $cont kbody) alternate)
+               (format port "$kclause ~a k~a" arity kbody)
+               (match alternate
+                 (#f #f)
+                 (($ $cont kalt) (format port " -> k~a" kalt)))
+               (newline port))
+              (($ $kargs names vars term)
+               (unless (null? vars)
+                 (format port "v~a[~a]~:{ v~a[~a]~}: "
+                         (car vars) (car names) (map list (cdr vars) (cdr 
names))))
+               (match (find-call term)
+                 (($ $continue k src exp)
+                  (match exp
+                    (($ $void) (format port "void"))
+                    (($ $const val) (format port "const address@hidden" val))
+                    (($ $prim name) (format port "prim ~a" name))
+                    (($ $fun free ($ $cont kbody)) (format port "fun k~a" 
kbody))
+                    (($ $closure label nfree) (format port "closure k~a (~a 
free)" label nfree))
+                    (($ $call proc args) (format port "call~{ v~a~}" (cons 
proc args)))
+                    (($ $callk k proc args) (format port "callk k~a~{ v~a~}" k 
(cons proc args)))
+                    (($ $primcall name args) (format port "~a~{ v~a~}" name 
args))
+                    (($ $values args) (format port "values~{ v~a~}" args))
+                    (($ $prompt escape? tag handler) (format port "prompt ~a 
v~a k~a" escape? tag handler)))
+                  (unless (= k (1+ label))
+                    (format port " -> k~a" k))
+                  (newline port))))))
+          (lp (1+ label)))))))
+
 (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
   (parameterize ((label-counter (1+ (dfg-max-label dfg)))
                  (var-counter (1+ (dfg-max-var dfg))))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index fe6e8b3..6b72ec1 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -531,7 +531,9 @@
               (add-deps! &box))
              (_
               (add-deps! (effects-clobber
-                          (logior fx &car &cdr &vector &struct &box)))
+                          (logand
+                           fx
+                           (cause (logior &car &cdr &vector &struct &box)))))
               #t)))
           (_ #t))
         (lp (1+ label))))))


hooks/post-receive
-- 
GNU Guile