[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-31-g2446f8e

[Ludovic Courtès]

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=2446f8e126d9a7c145c4868f2a918d2dfb226d4e

The branch, stable-2.0 has been updated
       via  2446f8e126d9a7c145c4868f2a918d2dfb226d4e (commit)
      from  226a56a3d454b18b2b57c4489fdb8efbf4cd8332 (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 2446f8e126d9a7c145c4868f2a918d2dfb226d4e
Author: Ludovic Courtès <address@hidden>
Date:   Sat Oct 6 01:24:46 2012 +0200

    Simplify calls to `equal?' when one argument is a constant.
    
    * module/language/tree-il/primitives.scm (*primitive-expand-table*): Add
      expansion rules for `equal?', when called with one constant and
      another argument.
    
    * test-suite/tests/tree-il.test (pass-if-primitives-resolved): New
      macro.
      ("primitives"): New test prefix.

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

Summary of changes:
 module/language/tree-il/primitives.scm |   27 ++++++++++++++++++
 test-suite/tests/tree-il.test          |   46 ++++++++++++++++++++++++++++++++
 2 files changed, 73 insertions(+), 0 deletions(-)

diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index a1c5adc..dc0a145 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -491,6 +491,33 @@
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
 (hashq-set! *primitive-expand-table*
+            'equal?
+            (case-lambda
+              ((src a b)
+               ;; Simplify cases where either A or B is constant.
+               (define (maybe-simplify a b)
+                 (and (const? a)
+                      (let ((v (const-exp a)))
+                        (cond
+                         ((eq? #f v)
+                          (make-application src (make-primitive-ref #f 'not)
+                                            (list b)))
+                         ((eq? '() v)
+                          (make-application src (make-primitive-ref #f 'null?)
+                                            (list b)))
+                         ((or (eq? #t v)
+                              (eq? #nil v)
+                              (symbol? v)
+                              (and (integer? v)
+                                   (<= v most-positive-fixnum)
+                                   (>= v most-negative-fixnum)))
+                          (make-application src (make-primitive-ref #f 'eq?)
+                                            (list a b)))
+                         (else #f)))))
+               (or (maybe-simplify a b) (maybe-simplify b a)))
+              (else #f)))
+
+(hashq-set! *primitive-expand-table*
             'dynamic-wind
             (case-lambda
               ((src pre thunk post)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 4ffdce0..bb7f908 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -58,6 +58,20 @@
      (assert-tree-il->glil with-partial-evaluation
                            in pat test ...))))
 
+(define-syntax-rule (pass-if-primitives-resolved in expected)
+  (pass-if (format #f "primitives-resolved in ~s" 'in)
+    (let* ((module   (let ((m (make-module)))
+                       (beautify-user-module! m)
+                       m))
+           (orig     (parse-tree-il 'in))
+           (resolved (expand-primitives! (resolve-primitives! orig module))))
+      (or (equal? (unparse-tree-il resolved) 'expected)
+          (begin
+            (format (current-error-port)
+                    "primitive test failed: got ~s, expected ~s"
+                    resolved 'expected)
+            #f)))))
+
 (define-syntax pass-if-tree-il->scheme
   (syntax-rules ()
     ((_ in pat)
@@ -70,6 +84,33 @@
          (_ #f))))))
 
 
+(with-test-prefix "primitives"
+
+  (pass-if-primitives-resolved
+   (apply (primitive equal?) (toplevel x) (const #f))
+   (apply (primitive not) (toplevel x)))
+
+  (pass-if-primitives-resolved
+   (apply (primitive equal?) (toplevel x) (const ()))
+   (apply (primitive null?) (toplevel x)))
+
+  (pass-if-primitives-resolved
+   (apply (primitive equal?) (const #t) (lexical x y))
+   (apply (primitive eq?) (const #t) (lexical x y)))
+
+  (pass-if-primitives-resolved
+   (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
+   (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+
+  (pass-if-primitives-resolved
+   (apply (primitive equal?) (const 42) (toplevel x))
+   (apply (primitive eq?) (const 42) (toplevel x)))
+
+  (pass-if-primitives-resolved
+   (apply (primitive equal?) (const #nil) (toplevel x))
+   (apply (primitive eq?) (const #nil) (toplevel x))))
+
+
 (with-test-prefix "tree-il->scheme"
   (pass-if-tree-il->scheme
    (case-lambda ((a) a) ((b c) (list b c)))
@@ -1704,3 +1745,8 @@
                               #:to 'assembly)))))
            (and (= (length w) 1)
                 (number? (string-contains (car w) "unsupported format 
option"))))))))
+
+;; Local Variables:
+;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
+;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)
+;; End:


hooks/post-receive
-- 
GNU Guile