mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

Simplify calls to `equal?' when one argument is a constant.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2012-10-06 01:24:46 +02:00
parent 226a56a3d4
commit 2446f8e126
2 changed files with 73 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

27
module/language/tree-il/primitives.scm
View file

@ -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

46
test-suite/tests/tree-il.test
View file

@ -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)
@ -69,6 +83,33 @@
(pat (guard guard-exp) #t)
(_ #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
@ -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: