[Guile-commits] GNU Guile branch, master, updated. v2.1.0-59-ge21dae4

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

The branch, master has been updated
       via  e21dae43fcd63b0e261e76d78e7eaf4aed10a190 (commit)
       via  072b5a277c302bbafefa627d00ee06ba82c85070 (commit)
       via  793ca4c4337d9d7c363e4effed1ddf9ef98e1072 (commit)
       via  257db78b6b6495ff46ff6be9a7b72e5cd40b27bb (commit)
       via  b5cb1c77fffb65642165cfc9153e95eba770b509 (commit)
      from  2c02a21023c946a3d31c43417d440d6babbf2622 (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 e21dae43fcd63b0e261e76d78e7eaf4aed10a190
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 29 19:49:41 2014 +0200

    Fix intmap-intersect corner case
    
    * module/language/cps/intmap.scm (intmap-intersect): Fix a corner case,
      as was recently fixed for intsets.

commit 072b5a277c302bbafefa627d00ee06ba82c85070
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 29 19:25:54 2014 +0200

    CSE truth inference pass uses intsets
    
    * module/language/cps/cse.scm (compute-truthy-expressions): Rewrite to
      use intsets instead of bitvectors.
      (apply-cse): Adapt.

commit 793ca4c4337d9d7c363e4effed1ddf9ef98e1072
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 29 19:47:25 2014 +0200

    Result of intsect-intersect will share structure with A if it can
    
    * module/language/cps/intset.scm (intset-intersect): Ensure that the
      result shares structure with A if possible, as intmaps do.

commit 257db78b6b6495ff46ff6be9a7b72e5cd40b27bb
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 29 19:40:43 2014 +0200

    Fix an intset-intersect corner case
    
    * module/language/cps/intset.scm (intset-intersect): Avoid creating
      invalid intsets when lowering an intset with a higher shift.

commit b5cb1c77fffb65642165cfc9153e95eba770b509
Author: Andy Wingo <address@hidden>
Date:   Sun Jun 29 19:31:27 2014 +0200

    Fix intset pruning for empty intsets
    
    * module/language/cps/intset.scm (make-intset/prune): Fix empty intset
      case.

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

Summary of changes:
 module/language/cps/cse.scm    |  125 +++++++++++++++++++---------------------
 module/language/cps/intmap.scm |   38 +++++++-----
 module/language/cps/intset.scm |  106 ++++++++++++++++++++--------------
 3 files changed, 146 insertions(+), 123 deletions(-)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index c8ca695..48cf922 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -63,7 +63,7 @@
 
 (define (compute-available-expressions dfg min-label label-count idoms)
   "Compute and return the continuations that may be reached if flow
-reaches a continuation N.  Returns a vector of bitvectors, whose first
+reaches a continuation N.  Returns a vector of intsets, whose first
 index corresponds to MIN-LABEL, and so on."
   (let* ((effects (compute-effects dfg min-label label-count))
          ;; Vector of intsets, indicating that at a continuation N, the
@@ -148,70 +148,65 @@ index corresponds to MIN-LABEL, and so on."
 (define (compute-truthy-expressions dfg min-label label-count)
   "Compute a \"truth map\", indicating which expressions can be shown to
 be true and/or false at each of LABEL-COUNT expressions in DFG, starting
-from MIN-LABEL.  Returns a vector of bitvectors, each bitvector twice as
-long as LABEL-COUNT.  The first half of the bitvector indicates labels
-that may be true, and the second half those that may be false.  It could
-be that both true and false proofs are available."
-  (let ((boolv (make-vector label-count #f)))
+from MIN-LABEL.  Returns a vector of intsets, each intset twice as long
+as LABEL-COUNT.  The even elements of the intset indicate labels that
+may be true, and the odd ones indicate those that may be false.  It
+could be that both true and false proofs are available."
+  (let ((boolv (make-vector label-count #f))
+        (revisit-label #f))
     (define (label->idx label) (- label min-label))
     (define (idx->label idx) (+ idx min-label))
-    (define (true-idx idx) idx)
-    (define (false-idx idx) (+ idx label-count))
+    (define (true-idx idx) (ash idx 1))
+    (define (false-idx idx) (1+ (ash idx 1)))
+
+    (define (propagate! pred succ out)
+      (let* ((succ-idx (label->idx succ))
+             (in (match (lookup-predecessors succ dfg)
+                   ;; Fast path: normal control flow.
+                   ((_) out)
+                   ;; Slow path: control-flow join.
+                   (_ (cond
+                       ((vector-ref boolv succ-idx)
+                        => (lambda (in)
+                             (intset-intersect in out)))
+                       (else out))))))
+        (when (and (<= succ pred)
+                   (or (not revisit-label) (< succ revisit-label))
+                   (not (eq? in (vector-ref boolv succ-idx))))
+          (set! revisit-label succ))
+        (vector-set! boolv succ-idx in)))
+
+    (vector-set! boolv 0 empty-intset)
 
     (let lp ((n 0))
-      (when (< n label-count)
-        (let ((bool (make-bitvector (* label-count 2) #f)))
-          (vector-set! boolv n bool)
-          (lp (1+ n)))))
-
-    (let ((tmp (make-bitvector (* label-count 2) #f)))
-      (define (bitvector-copy! dst src)
-        (bitvector-fill! dst #f)
-        (bit-set*! dst src #t))
-      (define (intersect! dst src)
-        (bitvector-copy! tmp src)
-        (bit-invert! tmp)
-        (bit-set*! dst tmp #f))
-      (let lp ((n 0) (first? #t) (changed? #f))
-        (cond
-         ((< n label-count)
-          (let* ((label (idx->label n))
-                 (bool (vector-ref boolv n))
-                 (prev-count (bit-count #t bool)))
-            ;; Intersect truthiness from all predecessors.
-            (let lp ((preds (lookup-predecessors label dfg))
-                     (initialized? #f))
-              (match preds
-                (() #t)
-                ((pred . preds)
-                 (let ((pidx (label->idx pred)))
-                   (cond
-                    ((and first? (<= n pidx))
-                     ;; Avoid intersecting back-edges and cross-edges on
-                     ;; the first iteration.
-                     (lp preds initialized?))
-                    (else
-                     (if initialized?
-                         (intersect! bool (vector-ref boolv pidx))
-                         (bitvector-copy! bool (vector-ref boolv pidx)))
-                     (match (lookup-cont pred dfg)
-                       (($ $kargs _ _ term)
-                        (match (find-call term)
-                          (($ $continue kf ($ $branch kt exp))
-                           (when (eqv? kt label)
-                             (bitvector-set! bool (true-idx pidx) #t))
-                           (when (eqv? kf label)
-                             (bitvector-set! bool (false-idx pidx) #t)))
-                          (_ #t)))
-                       (_ #t))
-                     (lp preds #t)))))))
-            (lp (1+ n) first?
-                (or changed?
-                    (not (= prev-count (bit-count #t bool)))))))
-         (else
-          (if (or first? changed?)
-              (lp 0 #f #f)
-              boolv)))))))
+      (cond
+       ((< n label-count)
+        (let* ((label (idx->label n))
+               ;; It's possible for "in" to be #f if it has no
+               ;; predecessors, as is the case for the ktail of a
+               ;; function with an iloop.
+               (in (or (vector-ref boolv n) empty-intset)))
+          (define (default-propagate)
+            (let visit-succs ((succs (cont-successors (lookup-cont label 
dfg))))
+              (match succs
+                (() (lp (1+ n)))
+                ((succ . succs)
+                 (propagate! label succ in)
+                 (visit-succs succs)))))
+          (match (lookup-cont label dfg)
+            (($ $kargs names syms body)
+             (match (find-call body)
+               (($ $continue k src ($ $branch kt))
+                (propagate! label k (intset-add in (false-idx n)))
+                (propagate! label kt (intset-add in (true-idx n)))
+                (lp (1+ n)))
+               (_ (default-propagate))))
+            (_ (default-propagate)))))
+       (revisit-label
+        (let ((n (label->idx revisit-label)))
+          (set! revisit-label #f)
+          (lp n)))
+       (else boolv)))))
 
 ;; Returns a map of label-idx -> (var-idx ...) indicating the variables
 ;; defined by a given labelled expression.
@@ -434,8 +429,8 @@ be that both true and false proofs are available."
   (define (label->idx label) (- label min-label))
   (define (idx->var idx) (+ idx min-var))
   (define (var->idx var) (- var min-var))
-  (define (true-idx idx) idx)
-  (define (false-idx idx) (+ idx (vector-length equiv-labels)))
+  (define (true-idx idx) (ash idx 1))
+  (define (false-idx idx) (1+ (ash idx 1)))
 
   (define (subst-var var)
     ;; It could be that the var is free in this function; if so,
@@ -495,8 +490,8 @@ be that both true and false proofs are available."
                   (match exp
                     (($ $branch kt exp)
                      (let* ((bool (vector-ref boolv (label->idx label)))
-                            (t (bitvector-ref bool (true-idx eidx)))
-                            (f (bitvector-ref bool (false-idx eidx))))
+                            (t (intset-ref bool (true-idx eidx)))
+                            (f (intset-ref bool (false-idx eidx))))
                        (if (eqv? t f)
                            (build-cps-term
                              ($continue k src
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 19d04c0..7be27c9 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -349,23 +349,31 @@
      (else
       (let* ((lo-shift (- lo-shift *branch-bits*))
              (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
-        (if (>= lo-idx *branch-size*)
-            ;; HI has a lower shift, but it not within LO.
-            empty-intmap
-            (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
-                                   lo-shift
-                                   (vector-ref lo-root lo-idx))))
-              (if lo-is-a?
-                  (intmap-intersect lo hi meet)
-                  (intmap-intersect hi lo meet))))))))
+        (cond
+         ((>= lo-idx *branch-size*)
+          ;; HI has a lower shift, but it not within LO.
+          empty-intmap)
+         ((vector-ref lo-root lo-idx)
+          => (lambda (lo-root)
+               (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
+                                      lo-shift
+                                      lo-root)))
+                 (if lo-is-a?
+                     (intmap-intersect lo hi meet)
+                     (intmap-intersect hi lo meet)))))
+         (else empty-intmap))))))
 
   (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
-    (let ((hi (make-intmap min
-                           (- hi-shift *branch-bits*)
-                           (vector-ref hi-root 0))))
-      (if lo-is-a?
-          (intmap-intersect lo hi meet)
-          (intmap-intersect hi lo meet))))
+    (cond
+     ((vector-ref hi-root 0)
+      => (lambda (hi-root)
+           (let ((hi (make-intmap min
+                                  (- hi-shift *branch-bits*)
+                                  hi-root)))
+             (if lo-is-a?
+                 (intmap-intersect lo hi meet)
+                 (intmap-intersect hi lo meet)))))
+     (else empty-intmap)))
 
   (match (cons a b)
     ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index 8bda290..4201cc8 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -91,23 +91,27 @@
     (make-intset min* shift* (clone-branch-and-set #f idx root))))
 
 (define (make-intset/prune min shift root)
-  (if (= shift *leaf-bits*)
-      (make-intset min shift root)
-      (let lp ((i 0) (elt #f))
-        (cond
-         ((< i *branch-size*)
-          (if (vector-ref root i)
-              (if elt
-                  (make-intset min shift root)
-                  (lp (1+ i) i))
-              (lp (1+ i) elt)))
-         (elt
-          (let ((shift (- shift *branch-bits*)))
-            (make-intset/prune (+ min (ash elt shift))
-                               shift
-                               (vector-ref root elt))))
-         ;; Shouldn't be reached...
-         (else empty-intset)))))
+  (cond
+   ((not root)
+    empty-intset)
+   ((= shift *leaf-bits*)
+    (make-intset min shift root))
+   (else
+    (let lp ((i 0) (elt #f))
+      (cond
+       ((< i *branch-size*)
+        (if (vector-ref root i)
+            (if elt
+                (make-intset min shift root)
+                (lp (1+ i) i))
+            (lp (1+ i) elt)))
+       (elt
+        (let ((shift (- shift *branch-bits*)))
+          (make-intset/prune (+ min (ash elt shift))
+                             shift
+                             (vector-ref root elt))))
+       ;; Shouldn't be reached...
+       (else empty-intset))))))
 
 (define (intset-add bs i)
   (define (adjoin i shift root)
@@ -376,38 +380,54 @@
      ((eq? a-node b-node) a-node)
      ((= shift *leaf-bits*) (intersect-leaves a-node b-node))
      (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
+
+  (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
+    (cond
+     ((<= lo-shift hi-shift)
+      ;; If LO has a lower shift and a lower min, it is disjoint.  If
+      ;; it has the same shift and a different min, it is also
+      ;; disjoint.
+      empty-intset)
+     (else
+      (let* ((lo-shift (- lo-shift *branch-bits*))
+             (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
+        (cond
+         ((>= lo-idx *branch-size*)
+          ;; HI has a lower shift, but it not within LO.
+          empty-intset)
+         ((vector-ref lo-root lo-idx)
+          => (lambda (lo-root)
+               (let ((lo (make-intset (+ lo-min (ash lo-idx lo-shift))
+                                      lo-shift
+                                      lo-root)))
+                 (if lo-is-a?
+                     (intset-intersect lo hi)
+                     (intset-intersect hi lo)))))
+         (else empty-intset))))))
+
+  (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
+    (cond
+     ((vector-ref hi-root 0)
+      => (lambda (hi-root)
+           (let ((hi (make-intset min
+                                  (- hi-shift *branch-bits*)
+                                  hi-root)))
+             (if lo-is-a?
+                 (intset-intersect lo hi)
+                 (intset-intersect hi lo)))))
+     (else empty-intset)))
+
   (match (cons a b)
     ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
      (cond
       ((< a-min b-min)
-       ;; Make A have the higher min.
-       (intset-intersect b a))
+       (different-mins a-min a-shift a-root b-min b-shift b #t))
       ((< b-min a-min)
-       (cond
-        ((<= b-shift a-shift)
-         ;; If B has a lower shift and a lower min, it is disjoint.  If
-         ;; it has the same shift and a different min, it is also
-         ;; disjoint.
-         empty-intset)
-        (else
-         (let* ((b-shift (- b-shift *branch-bits*))
-                (b-idx (ash (- a-min b-min) (- b-shift))))
-           (if (>= b-idx *branch-size*)
-               ;; A has a lower shift, but it not within B.
-               empty-intset
-               (intset-intersect a
-                                 (make-intset (+ b-min (ash b-idx b-shift))
-                                              b-shift
-                                              (vector-ref b-root b-idx))))))))
-      ((< b-shift a-shift)
-       ;; Make A have the lower shift.
-       (intset-intersect b a))
+       (different-mins b-min b-shift b-root a-min a-shift a #f))
       ((< a-shift b-shift)
-       ;; A and B have the same min but a different shift.  Recurse down.
-       (intset-intersect a
-                         (make-intset b-min
-                                      (- b-shift *branch-bits*)
-                                      (vector-ref b-root 0))))
+       (different-shifts-same-min b-min b-shift b-root a #t))
+      ((< b-shift a-shift)
+       (different-shifts-same-min a-min a-shift a-root b #f))
       (else
        ;; At this point, A and B cover the same range.
        (let ((root (intersect a-shift a-root b-root)))


hooks/post-receive
-- 
GNU Guile