guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-148-g9b175


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-148-g9b1750e
Date: Tue, 15 May 2012 10:25:54 +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=9b1750ed4250c6ad3bcf764b4d2bdeec6ca2c79e

The branch, stable-2.0 has been updated
       via  9b1750ed4250c6ad3bcf764b4d2bdeec6ca2c79e (commit)
       via  f49fd9afd698706bd7ff474412b7db0586ad0a56 (commit)
       via  1fb39dc55fd55476a0e7be6d483f705d9bf8fead (commit)
      from  3742d778fbc6ea879437c19aeebe09179dceffdf (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 9b1750ed4250c6ad3bcf764b4d2bdeec6ca2c79e
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 12:21:57 2012 +0200

    stronger conditional optimization
    
    * module/language/tree-il/peval.scm (peval): If we can lift one common
      test, see if we can lift others as well.
    
    * test-suite/tests/peval.test: Add a test.

commit f49fd9afd698706bd7ff474412b7db0586ad0a56
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 12:18:30 2012 +0200

    optimization for chain of if expressions with common tests
    
    * module/language/tree-il/peval.scm (peval): Optimize common tests in
      chains of "if" expressions, like those generated by matchers.
    
    * test-suite/tests/peval.test ("partial evaluation"): Add a test.

commit 1fb39dc55fd55476a0e7be6d483f705d9bf8fead
Author: Andy Wingo <address@hidden>
Date:   Tue May 15 12:14:22 2012 +0200

    mvoe tree-il=? and tree-il-hash to tree-il.scm
    
    * module/language/tree-il.scm (tree-il=?, tree-il-hash): Move these
      helpers here, from cse.scm.  Export them.
    
    * module/language/tree-il/cse.scm (cse): Adapt accordingly.

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

Summary of changes:
 module/language/tree-il.scm       |   69 +++++++++++++++++++++++++++++++++-
 module/language/tree-il/cse.scm   |   71 ++++-------------------------------
 module/language/tree-il/peval.scm |   75 +++++++++++++++++++++++++++++++++----
 test-suite/tests/peval.test       |   58 ++++++++++++++++++++++++++++-
 4 files changed, 200 insertions(+), 73 deletions(-)

diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 3ee89fb..1ac1809 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -59,7 +59,10 @@
             tree-il-fold
             make-tree-il-folder
             post-order!
-            pre-order!))
+            pre-order!
+
+            tree-il=?
+            tree-il-hash))
 
 (define (print-tree-il exp port)
   (format port "#<tree-il ~S>" (unparse-tree-il exp)))
@@ -647,3 +650,67 @@ This is an implementation of `foldts' as described by Andy 
Wingo in
 
         (else #f))
       x)))
+
+;; FIXME: We should have a better primitive than this.
+(define (struct-nfields x)
+  (/ (string-length (symbol->string (struct-layout x))) 2))
+
+(define (tree-il=? a b)
+  (cond
+   ((struct? a)
+    (and (struct? b)
+         (eq? (struct-vtable a) (struct-vtable b))
+         ;; Assume that all structs are tree-il, so we skip over the
+         ;; src slot.
+         (let lp ((n (1- (struct-nfields a))))
+           (or (zero? n)
+               (and (tree-il=? (struct-ref a n) (struct-ref b n))
+                    (lp (1- n)))))))
+   ((pair? a)
+    (and (pair? b)
+         (tree-il=? (car a) (car b))
+         (tree-il=? (cdr a) (cdr b))))
+   (else
+    (equal? a b))))
+
+(define-syntax hash-bits
+  (make-variable-transformer
+   (lambda (x)
+     (syntax-case x ()
+       (var
+        (identifier? #'var)
+        (logcount most-positive-fixnum))))))
+
+(define (tree-il-hash exp)
+  (let ((hash-depth 4)
+        (hash-width 3))
+    (define (hash-exp exp depth)
+      (define (rotate x bits)
+        (logior (ash x (- bits))
+                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
+      (define (mix h1 h2)
+        (logxor h1 (rotate h2 8)))
+      (define (hash-struct s)
+        (let ((len (struct-nfields s))
+              (h (hashq (struct-vtable s) most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((i (max (- len hash-width) 1)) (h h))
+                (if (< i len)
+                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
+                    h)))))
+      (define (hash-list l)
+        (let ((h (hashq 'list most-positive-fixnum)))
+          (if (zero? depth)
+              h
+              (let lp ((l l) (width 0) (h h))
+                (if (< width hash-width)
+                    (lp (cdr l) (1+ width)
+                        (mix (hash-exp (car l) (1+ depth)) h))
+                    h)))))
+      (cond
+       ((struct? exp) (hash-struct exp))
+       ((list? exp) (hash-list exp))
+       (else (hash exp most-positive-fixnum))))
+
+    (hash-exp exp 0)))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index f55c481..a3b4a9d 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -189,67 +189,12 @@
   (define (bailout? exp)
     (causes-effects? (compute-effects exp) &definite-bailout))
 
-  (define (struct-nfields x)
-    (/ (string-length (symbol->string (struct-layout x))) 2))
-
-  (define hash-bits (logcount most-positive-fixnum))
-  (define hash-depth 4)
-  (define hash-width 3)
-  (define (hash-expression exp)
-    (define (hash-exp exp depth)
-      (define (rotate x bits)
-        (logior (ash x (- bits))
-                (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
-      (define (mix h1 h2)
-        (logxor h1 (rotate h2 8)))
-      (define (hash-struct s)
-        (let ((len (struct-nfields s))
-              (h (hashq (struct-vtable s) most-positive-fixnum)))
-          (if (zero? depth)
-              h
-              (let lp ((i (max (- len hash-width) 1)) (h h))
-                (if (< i len)
-                    (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
-                    h)))))
-      (define (hash-list l)
-        (let ((h (hashq 'list most-positive-fixnum)))
-          (if (zero? depth)
-              h
-              (let lp ((l l) (width 0) (h h))
-                (if (< width hash-width)
-                    (lp (cdr l) (1+ width)
-                        (mix (hash-exp (car l) (1+ depth)) h))
-                    h)))))
-      (cond
-       ((struct? exp) (hash-struct exp))
-       ((list? exp) (hash-list exp))
-       (else (hash exp most-positive-fixnum))))
-    (hash-exp exp 0))
-
-  (define (expressions-equal? a b)
-    (cond
-     ((struct? a)
-      (and (struct? b)
-           (eq? (struct-vtable a) (struct-vtable b))
-           ;; Assume that all structs are tree-il, so we skip over the
-           ;; src slot.
-           (let lp ((n (1- (struct-nfields a))))
-             (or (zero? n)
-                 (and (expressions-equal? (struct-ref a n) (struct-ref b n))
-                      (lp (1- n)))))))
-     ((pair? a)
-      (and (pair? b)
-           (expressions-equal? (car a) (car b))
-           (expressions-equal? (cdr a) (cdr b))))
-     (else
-      (equal? a b))))
-
   (define (hasher n)
     (lambda (x size) (modulo n size)))
 
   (define (add-to-db exp effects ctx db)
     (let ((v (vector exp effects ctx))
-          (h (hash-expression exp)))
+          (h (tree-il-hash exp)))
       (vhash-cons v h db (hasher h))))
 
   (define (control-flow-boundary db)
@@ -260,12 +205,12 @@
     (define (entry-matches? v1 v2)
       (match (if (vector? v1) v1 v2)
         (#(exp* effects* ctx*)
-         (and (expressions-equal? exp exp*)
+         (and (tree-il=? exp exp*)
               (or (not ctx) (eq? ctx* ctx))))
         (_ #f)))
       
     (let ((len (vlist-length db))
-          (h (hash-expression exp)))
+          (h (tree-il-hash exp)))
       (and (vhash-assoc #t db entry-matches? (hasher h))
            (let lp ((n 0))
              (and (< n len)
@@ -282,7 +227,7 @@
                           (unparse-tree-il exp*) effects* ctx*)
                      (or (and (= h h*)
                               (or (not ctx) (eq? ctx ctx*))
-                              (expressions-equal? exp exp*))
+                              (tree-il=? exp exp*))
                          (and (effects-commute? effects effects*)
                               (lp (1+ n)))))))))))
 
@@ -333,7 +278,7 @@
 
   (define (add-to-env exp name sym db env)
     (let* ((v (vector exp name sym (vlist-length db)))
-           (h (hash-expression exp)))
+           (h (tree-il-hash exp)))
       (vhash-cons v h env (hasher h))))
 
   (define (augment-env env names syms exps db)
@@ -350,7 +295,7 @@
     (define (entry-matches? v1 v2)
       (match (if (vector? v1) v1 v2)
         (#(exp* name sym db)
-         (expressions-equal? exp exp*))
+         (tree-il=? exp exp*))
         (_ #f)))
       
     (define (unroll db base n)
@@ -364,7 +309,7 @@
              (and (effects-commute? effects effects*)
                   (unroll db (1+ base) (1- n)))))))
 
-    (let ((h (hash-expression exp)))
+    (let ((h (tree-il-hash exp)))
       (and (effect-free? (exclude-effects effects &type-check))
            (vhash-assoc exp env entry-matches? (hasher h))
            (let ((env-len (vlist-length env))
@@ -374,7 +319,7 @@
                     (match (vlist-ref env n)
                       ((#(exp* name sym db-len*) . h*)
                        (and (unroll db m (- db-len db-len*))
-                            (if (and (= h h*) (expressions-equal? exp* exp))
+                            (if (and (= h h*) (tree-il=? exp* exp))
                                 (make-lexical-ref (tree-il-src exp) name sym)
                                 (lp (1+ n) (- db-len db-len*))))))))))))
 
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 3b22b68..15c7164 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -997,20 +997,79 @@ top-level bindings from ENV and return the resulting 
expression."
          ((test) (make-const #f #t))
          (else exp)))
       (($ <conditional> src condition subsequent alternate)
+       (define (call-with-failure-thunk exp proc)
+         (match exp
+           (($ <application> _ _ ()) (proc exp))
+           (($ <const>) (proc exp))
+           (($ <void>) (proc exp))
+           (($ <lexical-ref>) (proc exp))
+           (_
+            (let ((t (gensym "failure-")))
+              (record-new-temporary! 'failure t 2)
+              (make-let
+               src (list 'failure) (list t)
+               (list
+                (make-lambda
+                 #f '()
+                 (make-lambda-case #f '() #f #f #f '() '() exp #f)))
+               (proc (make-application #f (make-lexical-ref #f 'failure t)
+                                       '())))))))
+       (define (simplify-conditional c)
+         (match c
+           ;; Swap the arms of (if (not FOO) A B), to simplify.
+           (($ <conditional> src
+               ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
+               subsequent alternate)
+            (simplify-conditional
+             (make-conditional src pred alternate subsequent)))
+           ;; Special cases for common tests in the predicates of chains
+           ;; of if expressions.
+           (($ <conditional> src
+               ($ <conditional> src* outer-test inner-test ($ <const> _ #f))
+               inner-subsequent
+               alternate)
+            (let lp ((alternate alternate))
+              (match alternate
+                ;; Lift a common repeated test out of a chain of if
+                ;; expressions.
+                (($ <conditional> _ (? (cut tree-il=? outer-test <>))
+                    other-subsequent alternate)
+                 (make-conditional
+                  src outer-test
+                  (simplify-conditional
+                   (make-conditional src* inner-test inner-subsequent
+                                     other-subsequent))
+                  alternate))
+                ;; Likewise, but punching through any surrounding
+                ;; failure continuations.
+                (($ <let> let-src (name) (sym) ((and thunk ($ <lambda>))) body)
+                 (make-let
+                  let-src (list name) (list sym) (list thunk)
+                  (lp body)))
+                ;; Otherwise, rotate AND tests to expose a simple
+                ;; condition in the front.  Although this may result in
+                ;; lexically binding failure thunks, the thunks will be
+                ;; compiled to labels allocation, so there's no actual
+                ;; code growth.
+                (_
+                 (call-with-failure-thunk
+                  alternate
+                  (lambda (failure)
+                    (make-conditional
+                     src outer-test
+                     (simplify-conditional
+                      (make-conditional src* inner-test inner-subsequent 
failure))
+                     failure)))))))
+           (_ c)))
        (match (for-test condition)
          (($ <const> _ val)
           (if val
               (for-tail subsequent)
               (for-tail alternate)))
-         ;; Swap the arms of (if (not FOO) A B), to simplify.
-         (($ <application> _ ($ <primitive-ref> _ 'not) (c))
-          (make-conditional src c
-                            (for-tail alternate)
-                            (for-tail subsequent)))
          (c
-          (make-conditional src c
-                            (for-tail subsequent)
-                            (for-tail alternate)))))
+          (simplify-conditional
+           (make-conditional src c (for-tail subsequent)
+                             (for-tail alternate))))))
       (($ <application> src
           ($ <primitive-ref> _ '@call-with-values)
           (producer
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 987b06c..aefb2e0 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -999,4 +999,60 @@
                    out))))
       ((lambda (y) (list y)) x))
     (let (x) (_) (_)
-         (apply (primitive list) (lexical x _)))))
+         (apply (primitive list) (lexical x _))))
+
+  ;; Here we test that a common test in a chain of ifs gets lifted.
+  (pass-if-peval resolve-primitives
+    (if (and (struct? x) (eq? (struct-vtable x) A))
+        (foo x)
+        (if (and (struct? x) (eq? (struct-vtable x) B))
+            (bar x)
+            (if (and (struct? x) (eq? (struct-vtable x) C))
+                (baz x)
+                (qux x))))
+    (let (failure) (_) ((lambda _
+                          (lambda-case
+                           ((() #f #f #f () ())
+                            (apply (toplevel qux) (toplevel x))))))
+         (if (apply (primitive struct?) (toplevel x))
+             (if (apply (primitive eq?)
+                        (apply (primitive struct-vtable) (toplevel x))
+                        (toplevel A))
+                 (apply (toplevel foo) (toplevel x))
+                 (if (apply (primitive eq?)
+                            (apply (primitive struct-vtable) (toplevel x))
+                            (toplevel B))
+                     (apply (toplevel bar) (toplevel x))
+                     (if (apply (primitive eq?)
+                                (apply (primitive struct-vtable) (toplevel x))
+                                (toplevel C))
+                         (apply (toplevel baz) (toplevel x))
+                         (apply (lexical failure _)))))
+             (apply (lexical failure _)))))
+
+  ;; Multiple common tests should get lifted as well.
+  (pass-if-peval resolve-primitives
+    (if (and (struct? x) (eq? (struct-vtable x) A) B)
+        (foo x)
+        (if (and (struct? x) (eq? (struct-vtable x) A) C)
+            (bar x)
+            (if (and (struct? x) (eq? (struct-vtable x) A) D)
+                (baz x)
+                (qux x))))
+    (let (failure) (_) ((lambda _
+                          (lambda-case
+                           ((() #f #f #f () ())
+                            (apply (toplevel qux) (toplevel x))))))
+         (if (apply (primitive struct?) (toplevel x))
+             (if (apply (primitive eq?)
+                        (apply (primitive struct-vtable) (toplevel x))
+                        (toplevel A))
+                 (if (toplevel B)
+                     (apply (toplevel foo) (toplevel x))
+                     (if (toplevel C)
+                         (apply (toplevel bar) (toplevel x))
+                         (if (toplevel D)
+                             (apply (toplevel baz) (toplevel x))
+                             (apply (lexical failure _)))))
+                 (apply (lexical failure _)))
+             (apply (lexical failure _))))))


hooks/post-receive
-- 
GNU Guile



reply via email to

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