mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

Simplify calls to 'eqv?' when one argument is an immediate constant.

Browse source 
* module/language/tree-il/primitives.scm (maybe-simplify-to-eq): New
  helper procedure shared by expanders for 'eqv?' and 'equal?'.
  (*primitive-expand-table*): Add expansion rule for 'eqv?'.

* test-suite/tests/tree-il.test ("primitives"): Add tests.
This commit is contained in:
Mark H Weaver 2012-10-08 11:56:10 -04:00
parent bcf87e35e1
commit 75a5de18a0
2 changed files with 73 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -490,24 +490,26 @@
(define-primitive-expander f64vector-set! (vec i x) (define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x)) (bytevector-ieee-double-native-set! vec (* i 8) x))
(hashq-set! *primitive-expand-table* ;; Appropriate for use with either 'eqv?' or 'equal?'.
'equal? (define maybe-simplify-to-eq
(case-lambda (case-lambda
((src a b) ((src a b)
;; Simplify cases where either A or B is constant. ;; Simplify cases where either A or B is constant.
(define (maybe-simplify a b) (define (maybe-simplify a b)
(and (const? a) (and (const? a)
(let ((v (const-exp a))) (let ((v (const-exp a)))
(and (or (memq v '(#f #t () #nil)) (and (or (memq v '(#f #t () #nil))
(symbol? v) (symbol? v)
(and (integer? v) (and (integer? v)
(exact? v) (exact? v)
(<= v most-positive-fixnum) (<= most-negative-fixnum v most-positive-fixnum)))
(>= v most-negative-fixnum))) (make-application src (make-primitive-ref #f 'eq?)
(make-application src (make-primitive-ref #f 'eq?) (list a b))))))
(list a b)))))) (or (maybe-simplify a b) (maybe-simplify b a)))
(or (maybe-simplify a b) (maybe-simplify b a))) (else #f)))
(else #f)))
(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
(hashq-set! *primitive-expand-table* (hashq-set! *primitive-expand-table*
'dynamic-wind 'dynamic-wind

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

@ -86,33 +86,65 @@
(with-test-prefix "primitives" (with-test-prefix "primitives"
(pass-if-primitives-resolved (with-test-prefix "eqv?"
(apply (primitive equal?) (const #f) (toplevel x))
(apply (primitive eq?) (const #f) (toplevel x)))
(pass-if-primitives-resolved (pass-if-primitives-resolved
(apply (primitive equal?) (const ()) (toplevel x)) (apply (primitive eqv?) (const #f) (toplevel x))
(apply (primitive eq?) (const ()) (toplevel x))) (apply (primitive eq?) (const #f) (toplevel x)))
(pass-if-primitives-resolved (pass-if-primitives-resolved
(apply (primitive equal?) (const #t) (lexical x y)) (apply (primitive eqv?) (const ()) (toplevel x))
(apply (primitive eq?) (const #t) (lexical x y))) (apply (primitive eq?) (const ()) (toplevel x)))
(pass-if-primitives-resolved (pass-if-primitives-resolved
(apply (primitive equal?) (const this-is-a-symbol) (toplevel x)) (apply (primitive eqv?) (const #t) (lexical x y))
(apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) (apply (primitive eq?) (const #t) (lexical x y)))
(pass-if-primitives-resolved (pass-if-primitives-resolved
(apply (primitive equal?) (const 42) (toplevel x)) (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
(apply (primitive eq?) (const 42) (toplevel x))) (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved (pass-if-primitives-resolved
(apply (primitive equal?) (const 42.0) (toplevel x)) (apply (primitive eqv?) (const 42) (toplevel x))
(apply (primitive equal?) (const 42.0) (toplevel x))) (apply (primitive eq?) (const 42) (toplevel x)))
(pass-if-primitives-resolved (pass-if-primitives-resolved
(apply (primitive equal?) (const #nil) (toplevel x)) (apply (primitive eqv?) (const 42.0) (toplevel x))
(apply (primitive eq?) (const #nil) (toplevel x)))) (apply (primitive eqv?) (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
(apply (primitive eqv?) (const #nil) (toplevel x))
(apply (primitive eq?) (const #nil) (toplevel x))))
(with-test-prefix "equal?"
(pass-if-primitives-resolved
(apply (primitive equal?) (const #f) (toplevel x))
(apply (primitive eq?) (const #f) (toplevel x)))
(pass-if-primitives-resolved
(apply (primitive equal?) (const ()) (toplevel x))
(apply (primitive eq?) (const ()) (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 42.0) (toplevel x))
(apply (primitive equal?) (const 42.0) (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" (with-test-prefix "tree-il->scheme"