guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-891-gd03c3c7


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-891-gd03c3c7
Date: Sun, 06 Apr 2014 08:46:05 +0000

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=d03c3c77950dafddec69e87c5f75bec4a4197a60

The branch, master has been updated
       via  d03c3c77950dafddec69e87c5f75bec4a4197a60 (commit)
       via  e84cdfb6d4e77344cae031c3a79828062818a27b (commit)
       via  df1bdc1ea79b3bde822775486955bd329d696bea (commit)
      from  9e94cd9bf504b99adbf4f6825ab09efcbf02656f (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 d03c3c77950dafddec69e87c5f75bec4a4197a60
Author: Andy Wingo <address@hidden>
Date:   Sat Apr 5 21:08:09 2014 +0200

    Flow-sensitive analysis of truth values
    
    * module/language/cps/cse.scm (compute-truthy-expressions):
      (compute-equivalent-subexpressions, apply-cse): Arrange to infer
      truthiness of expressions, and use that information to elide redundant
      tests.

commit e84cdfb6d4e77344cae031c3a79828062818a27b
Author: Andy Wingo <address@hidden>
Date:   Sat Apr 5 21:06:35 2014 +0200

    Add effects for specialized primitives
    
    * module/language/cps/effects-analysis.scm (make-vector)
      (make-vector/immediate, vector-ref/immediate, vector-set!/immediate)
      (struct-ref/immediate, struct-set!/immediate): Add effects.

commit df1bdc1ea79b3bde822775486955bd329d696bea
Author: Andy Wingo <address@hidden>
Date:   Sat Apr 5 14:38:37 2014 +0200

    Minor cleanup/optimization in CSE
    
    * module/language/cps/cse.scm (compute-available-expressions): Remove
      needless for-each definition.
      (compute-equivalent-subexpressions): Optimize for-each/2.

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

Summary of changes:
 module/language/cps/cse.scm              |  182 ++++++++++++++++++++++--------
 module/language/cps/effects-analysis.scm |   30 +++++-
 2 files changed, 165 insertions(+), 47 deletions(-)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 4f99483..a0dea1a 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -58,12 +58,6 @@ index corresponds to MIN-LABEL, and so on."
     (define (label->idx label) (- label min-label))
     (define (idx->label idx) (+ idx min-label))
 
-    (define (for-each f l)
-      (let lp ((l l))
-        (when (pair? l)
-          (f (car l))
-          (lp (cdr l)))))
-
     (let lp ((n 0))
       (when (< n label-count)
         (let ((in (make-bitvector label-count #f))
@@ -138,6 +132,75 @@ index corresponds to MIN-LABEL, and so on."
               (lp 0 #f #f)
               avail-in)))))))
 
+(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)))
+    (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))
+
+    (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-predecessors pred dfg)
+                       ((test)
+                        (let ((tidx (label->idx test)))
+                          (match (lookup-cont pred dfg)
+                            (($ $kif kt kf)
+                             (when (eqv? kt label)
+                               (bitvector-set! bool (true-idx tidx) #t))
+                             (when (eqv? kf label)
+                               (bitvector-set! bool (false-idx tidx) #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)))))))
+
 (define (compute-defs dfg min-label label-count)
   (define (cont-defs k)
     (match (lookup-cont k dfg)
@@ -258,13 +321,21 @@ index corresponds to MIN-LABEL, and so on."
           (idoms (compute-idoms dfg min-label label-count))
           (defs (compute-defs dfg min-label label-count))
           (var-substs (make-vector var-count #f))
-          (label-substs (make-vector label-count #f))
+          (equiv-labels (make-vector label-count #f))
           (equiv-set (make-hash-table)))
       (define (idx->label idx) (+ idx min-label))
       (define (label->idx label) (- label min-label))
       (define (idx->var idx) (+ idx min-var))
       (define (var->idx var) (- var min-var))
 
+      (define (for-each/2 f l1 l2)
+        (unless (= (length l1) (length l2))
+          (error "bad lengths" l1 l2))
+        (let lp ((l1 l1) (l2 l2))
+          (when (pair? l1)
+            (f (car l1) (car l2))
+            (lp (cdr l1) (cdr l2)))))
+
       (define (subst-var var)
         ;; It could be that the var is free in this function; if so, its
         ;; name will be less than min-var.
@@ -311,36 +382,38 @@ index corresponds to MIN-LABEL, and so on."
                        (when exp-key
                          (hash-set! equiv-set exp-key (cons label equiv))))
                       ((candidate . candidates)
-                       (let ((subst (vector-ref defs (label->idx candidate))))
-                         (cond
-                          ((not (bitvector-ref avail (label->idx candidate)))
-                           ;; This expression isn't available here; try
-                           ;; the next one.
-                           (lp candidates))
-                          (else
-                           ;; Yay, a match.  Mark expression for
-                           ;; replacement with $values.
-                           (vector-set! label-substs (label->idx label) subst)
-                           ;; If we dominate the successor, mark vars
-                           ;; for substitution.
-                           (when (= label (vector-ref idoms (label->idx k)))
-                             (for-each
-                              (lambda (var subst-var)
-                                (vector-set! var-substs (var->idx var) 
subst-var))
-                              (vector-ref defs (label->idx label))
-                              subst))))))))))))
+                       (cond
+                        ((not (bitvector-ref avail (label->idx candidate)))
+                         ;; This expression isn't available here; try
+                         ;; the next one.
+                         (lp candidates))
+                        (else
+                         ;; Yay, a match.  Mark expression as equivalent.
+                         (vector-set! equiv-labels (label->idx label)
+                                      candidate)
+                         ;; If we dominate the successor, mark vars
+                         ;; for substitution.
+                         (when (= label (vector-ref idoms (label->idx k)))
+                           (for-each/2
+                            (lambda (var subst-var)
+                              (vector-set! var-substs (var->idx var) 
subst-var))
+                            (vector-ref defs (label->idx label))
+                            (vector-ref defs (label->idx candidate)))))))))))))
             (_ #f))
           (lp (1+ label))))
       (values (compute-dom-edges idoms min-label)
-              label-substs min-label var-substs min-var)))
+              equiv-labels defs min-label var-substs min-var)))
 
   (call-with-values (lambda () (compute-label-and-var-ranges fun)) compute))
 
-(define (apply-cse fun dfg doms label-substs min-label var-substs min-var)
+(define (apply-cse fun dfg
+                   doms equiv-labels defs min-label var-substs min-var boolv)
   (define (idx->label idx) (+ idx min-label))
   (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 (subst-var var)
     ;; It could be that the var is free in this function; if so,
@@ -383,18 +456,36 @@ index corresponds to MIN-LABEL, and so on."
         (($ $prompt escape? tag handler)
          ($prompt escape? (subst-var tag) handler))))
 
-    (define (visit-exp* k exp)
+    (define (visit-exp* k src exp)
       (match exp
-        ((and fun ($ $fun)) (cse fun dfg))
+        ((and fun ($ $fun))
+         (build-cps-term ($continue k src ,(cse fun dfg))))
         (_
-         (match (lookup-cont k dfg)
-           (($ $kargs names vars)
-            (cond
-             ((vector-ref label-substs (label->idx label))
-              => (lambda (vars)
-                   (build-cps-exp ($values vars))))
-             (else (visit-exp exp))))
-           (_ (visit-exp exp))))))
+         (cond
+          ((vector-ref equiv-labels (label->idx label))
+           => (lambda (equiv)
+                (let* ((eidx (label->idx equiv))
+                       (vars (vector-ref defs eidx)))
+                  (rewrite-cps-term (lookup-cont k dfg)
+                    (($ $kif kt kf)
+                     ,(let* ((bool (vector-ref boolv (label->idx label)))
+                             (t (bitvector-ref bool (true-idx eidx)))
+                             (f (bitvector-ref bool (false-idx eidx))))
+                        (if (eqv? t f)
+                            (build-cps-term
+                              ($continue k src ,(visit-exp exp)))
+                            (build-cps-term
+                              ($continue (if t kt kf) src ($values ()))))))
+                    (($ $kargs)
+                     ($continue k src ($values vars)))
+                    ;; There is no point in adding a case for $ktail, as
+                    ;; only $values, $call, or $callk can continue to
+                    ;; $ktail.
+                    (_
+                     ($continue k src ,(visit-exp exp)))))))
+          (else
+           (build-cps-term
+             ($continue k src ,(visit-exp exp))))))))
 
     (define (visit-dom-conts label)
       (let ((cont (lookup-cont label dfg)))
@@ -413,22 +504,23 @@ index corresponds to MIN-LABEL, and so on."
        ($letrec names syms (map (lambda (fun) (cse fun dfg)) funs)
                 ,(visit-term body label)))
       (($ $continue k src exp)
-       ,(let* ((exp (visit-exp* k exp))
-               (conts (append-map visit-dom-conts
-                                  (vector-ref doms (label->idx label)))))
+       ,(let ((conts (append-map visit-dom-conts
+                                 (vector-ref doms (label->idx label)))))
           (if (null? conts)
-              (build-cps-term ($continue k src ,exp))
-              (build-cps-term ($letk ,conts ($continue k src ,exp))))))))
+              (visit-exp* k src exp)
+              (build-cps-term
+                ($letk ,conts ,(visit-exp* k src exp))))))))
 
   (rewrite-cps-exp fun
     (($ $fun src meta free body)
      ($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
 
-;; TODO: Truth values, and interprocedural CSE.
 (define (cse fun dfg)
   (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
-    (lambda (doms label-substs min-label var-substs min-var)
-      (apply-cse fun dfg doms label-substs min-label var-substs min-var))))
+    (lambda (doms equiv-labels defs min-label var-substs min-var)
+      (apply-cse fun dfg doms equiv-labels defs min-label var-substs min-var
+                 (compute-truthy-expressions dfg
+                                             min-label (vector-length 
doms))))))
 
 (define (eliminate-common-subexpressions fun)
   (call-with-values (lambda () (renumber fun))
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 1725d28..a8e7cb2 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -294,8 +294,12 @@
 ;; Vectors.
 (define-primitive-effects
   ((vector . _) (cause &allocation))
+  ((make-vector n init) (logior (cause &type-check) (cause &allocation)))
+  ((make-vector/immediate n init) (cause &allocation))
   ((vector-ref v n) (logior (cause &type-check) &vector))
+  ((vector-ref/immediate v n) (logior (cause &type-check) &vector))
   ((vector-set! v n x) (logior (cause &type-check) (cause &vector)))
+  ((vector-set!/immediate v n x) (logior (cause &type-check) (cause &vector)))
   ((vector-length v) (cause &type-check)))
 
 ;; Variables.
@@ -323,6 +327,17 @@
              (4 &struct-4)
              (5 &struct-5)
              (_ &struct-6+))))
+  ((struct-ref/immediate s n)
+   (logior (cause &type-check)
+           (match (lookup-constant-index n dfg)
+             (#f &struct)
+             (0 &struct-0)
+             (1 &struct-1)
+             (2 &struct-2)
+             (3 &struct-3)
+             (4 &struct-4)
+             (5 &struct-5)
+             (_ &struct-6+))))
   ((struct-set! s n x)
    (logior (cause &type-check)
            (match (lookup-constant-index n dfg)
@@ -334,6 +349,17 @@
              (4 (cause &struct-4))
              (5 (cause &struct-5))
              (_ (cause &struct-6+)))))
+  ((struct-set!/immediate s n x)
+   (logior (cause &type-check)
+           (match (lookup-constant-index n dfg)
+             (#f (cause &struct))
+             (0 (cause &struct-0))
+             (1 (cause &struct-1))
+             (2 (cause &struct-2))
+             (3 (cause &struct-3))
+             (4 (cause &struct-4))
+             (5 (cause &struct-5))
+             (_ (cause &struct-6+)))))
   ((struct-vtable s) (cause &type-check)))
 
 ;; Strings.
@@ -461,8 +487,8 @@
               (($ $arity _ () _ () #f) (logior (cause &allocation)
                                                (cause &type-check)))))
            (($ $kif) &no-effects)
-           (($ $kentry) &type-check)
-           (($ $kclause) &type-check)
+           (($ $kentry) (cause &type-check))
+           (($ $kclause) (cause &type-check))
            (($ $ktail) &no-effects)))
         (lp (1+ n))))
     effects))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]