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.

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index a1c5adc..dc0a145 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -490,6 +490,33 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (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

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 4ffdce0..bb7f908 100644 (file)
--- 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))))))
 
 \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))))
+
+\f
 (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: