[Guile-commits] GNU Guile branch, master, updated. v2.1.0-87-gb9a5bac

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

The branch, master has been updated
       via  b9a5bac69082114a75278c0d0fceedab787dbf7c (commit)
       via  ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31 (commit)
       via  44954194c936bee2f2faa4225480cb9dd2cbdcd8 (commit)
       via  7700e67226e76eb53ceef12368992161243b59df (commit)
      from  6fc634f8a378475efa336afadb8cef26807bd0cb (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 b9a5bac69082114a75278c0d0fceedab787dbf7c
Author: Andy Wingo <address@hidden>
Date:   Sun Jul 20 20:52:06 2014 +0200

    Better simplification of literal constants that continue to branches
    
    * module/language/cps/simplify.scm (eta-reduce): Constants that continue
      to branches eta-reduce to the true or false branch.

commit ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31
Author: Andy Wingo <address@hidden>
Date:   Sun Jul 20 20:19:01 2014 +0200

    CPS will not see "not" primcalls
    
    * module/language/tree-il/compile-cps.scm (convert): Remove "not"
      primcalls.
    
    * module/language/cps/effects-analysis.scm (values):
    * module/language/cps/types.scm: Remove special cases for the "not"
      primcall.

commit 44954194c936bee2f2faa4225480cb9dd2cbdcd8
Author: Andy Wingo <address@hidden>
Date:   Sun Jul 6 12:38:26 2014 +0200

    Simplify pass rewrite scope tree to reflect dominator tree
    
    * module/language/cps/simplify.scm (redominate): Add micropass to
      rewrite the scope tree to reflect the dominator tree.  Will enable
      better eta reduction.

commit 7700e67226e76eb53ceef12368992161243b59df
Author: Andy Wingo <address@hidden>
Date:   Sun Jul 6 12:17:58 2014 +0200

    Remove dead case in CSE
    
    * module/language/cps/cse.scm (apply-cse): Remove a case that couldn't
      occur.

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

Summary of changes:
 module/language/cps/cse.scm              |    2 -
 module/language/cps/effects-analysis.scm |    3 +-
 module/language/cps/simplify.scm         |   99 +++++++++++++++++++++++++++++-
 module/language/cps/types.scm            |   17 -----
 module/language/tree-il/compile-cps.scm  |    9 +++
 5 files changed, 107 insertions(+), 23 deletions(-)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 204480e..3a03ede 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -445,8 +445,6 @@ could be that both true and false proofs are available."
 
   (define (visit-fun-cont cont)
     (rewrite-cps-cont cont
-      (($ $cont label ($ $kargs names vars body))
-       (label ($kargs names vars ,(visit-term body label))))
       (($ $cont label ($ $kfun src meta self tail clause))
        (label ($kfun src meta self ,tail
                 ,(and clause (visit-fun-cont clause)))))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index d59283c..246b22e 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -256,8 +256,7 @@ is or might be a read or a write to the same location as A."
 
 ;; Miscellaneous.
 (define-primitive-effects
-  ((values . _))
-  ((not arg)))
+  ((values . _)))
 
 ;; Generic effect-free predicates.
 (define-primitive-effects
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 5185889..2c33edd 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -85,6 +85,30 @@
       (reduce* k scope #f))
     (define (reduce-values k scope)
       (reduce* k scope #t))
+    (define (reduce-const k src scope const)
+      (let lp ((k k) (seen '()) (const const))
+        (match (lookup-cont k dfg)
+          (($ $kargs (_) (arg) term)
+           (match (find-call term)
+             (($ $continue k* src* ($ $values (arg*)))
+              (and (eqv? arg arg*)
+                   (not (memq k* seen))
+                   (lp k* (cons k seen) const)))
+             (($ $continue k* src* ($ $primcall 'not (arg*)))
+              (and (eqv? arg arg*)
+                   (not (memq k* seen))
+                   (lp k* (cons k seen) (not const))))
+             (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
+              (and (eqv? arg arg*)
+                   (let ((k* (if const kt k*)))
+                     (and (continuation-bound-in? k* scope dfg)
+                          (build-cps-term
+                            ($continue k* src ($values ())))))))
+             (_
+              (and (continuation-bound-in? k scope dfg)
+                   (build-cps-term
+                     ($continue k src ($const const)))))))
+          (_ #f))))
     (define (visit-cont cont scope)
       (rewrite-cps-cont cont
         (($ $cont sym ($ $kargs names syms body))
@@ -104,11 +128,15 @@
            ,(visit-term body scope)))
         (($ $letrec names syms funs body)
          ($letrec names syms (map visit-fun funs)
-                  ,(visit-term body scope)))
+           ,(visit-term body scope)))
         (($ $continue k src ($ $values args))
          ($continue (reduce-values k scope) src ($values args)))
         (($ $continue k src (and fun ($ $fun)))
          ($continue (reduce k scope) src ,(visit-fun fun)))
+        (($ $continue k src ($ $const const))
+         ,(let ((k (reduce k scope)))
+            (or (reduce-const k src scope const)
+                (build-cps-term ($continue k src ($const const))))))
         (($ $continue k src exp)
          ($continue (reduce k scope) src ,exp))))
     (define (visit-fun fun)
@@ -234,7 +262,74 @@
          ($fun (map subst free) ,(must-visit-cont body)))))
     (must-visit-cont fun)))
 
+;; Rewrite the scope tree to reflect the dominator tree.  Precondition:
+;; the fun has been renumbered, its min-label is 0, and its labels are
+;; packed.
+(define (redominate fun)
+  (let* ((dfg (compute-dfg fun))
+         (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
+         (doms (compute-dom-edges idoms 0)))
+    (define (visit-fun-cont cont)
+      (rewrite-cps-cont cont
+        (($ $cont label ($ $kfun src meta self tail clause))
+         (label ($kfun src meta self ,tail
+                  ,(and clause (visit-fun-cont clause)))))
+        (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
+         (label ($kclause ,arity ,(visit-cont kbody body)
+                          ,(and alternate (visit-fun-cont alternate)))))))
+
+    (define (visit-cont label cont)
+      (rewrite-cps-cont cont
+        (($ $kargs names vars body)
+         (label ($kargs names vars ,(visit-term body label))))
+        (_ (label ,cont))))
+
+    (define (visit-exp k src exp)
+      (rewrite-cps-term exp
+        (($ $fun free body)
+         ($continue k src ($fun free ,(visit-fun-cont body))))
+        (_
+         ($continue k src ,exp))))
+
+    (define (visit-term term label)
+      (define (visit-dom-conts label)
+        (let ((cont (lookup-cont label dfg)))
+          (match cont
+            (($ $ktail) '())
+            (($ $kargs) (list (visit-cont label cont)))
+            (else
+             (cons (visit-cont label cont)
+                   (visit-dom-conts* (vector-ref doms label)))))))
+
+      (define (visit-dom-conts* labels)
+        (match labels
+          (() '())
+          ((label . labels)
+           (append (visit-dom-conts label)
+                   (visit-dom-conts* labels)))))
+
+      (rewrite-cps-term term
+        (($ $letk conts body)
+         ,(visit-term body label))
+        (($ $letrec names syms funs body)
+         ($letrec names syms (let lp ((funs funs))
+                               (match funs
+                                 (() '())
+                                 ((($ $fun free body) . funs)
+                                  (cons (build-cps-exp
+                                          ($fun free ,(visit-fun-cont body)))
+                                        (lp funs)))))
+           ,(visit-term body label)))
+        (($ $continue k src exp)
+         ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
+            (if (null? conts)
+                (visit-exp k src exp)
+                (build-cps-term
+                  ($letk ,conts ,(visit-exp k src exp))))))))
+
+    (visit-fun-cont fun)))
+
 (define (simplify fun)
   ;; Renumbering prunes continuations that are made unreachable by
   ;; eta/beta reductions.
-  (renumber (eta-reduce (beta-reduce fun))))
+  (redominate (renumber (eta-reduce (beta-reduce fun)))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 677f542..2a21925 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -450,23 +450,6 @@ minimum, and maximum."
 
 
 ;;;
-;;; Miscellaneous.
-;;;
-
-(define-simple-type-checker (not &all-types))
-(define-type-inferrer (not val result)
-  (cond
-   ((and (eqv? (&type val) &boolean)
-         (eqv? (&min val) (&max val)))
-    (let ((val (if (zero? (&min val)) 1 0)))
-      (define! result &boolean val val)))
-   (else
-    (define! result &boolean 0 1))))
-
-
-
-
-;;;
 ;;; Generic effect-free predicates.
 ;;;
 
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index d81a82c..3822316 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -363,6 +363,15 @@
                        (kf ($kargs () () ($continue k src ($const #f)))))
                  ($continue kf src
                    ($branch kt ($primcall name args)))))))))
+      ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
+       (convert-args args
+         (lambda (args)
+           (let-fresh (kt kf) ()
+             (build-cps-term
+               ($letk ((kt ($kargs () () ($continue k src ($const #f))))
+                       (kf ($kargs () () ($continue k src ($const #t)))))
+                 ($continue kf src
+                   ($branch kt ($values args)))))))))
       ((and (eq? name 'list)
             (and-map (match-lambda
                       ((or ($ <const>)


hooks/post-receive
-- 
GNU Guile