mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Optimize Equality Primitives
* module/language/tree-il/primitives.scm: add equality-primitive?, which is true for eq?, eqv?, and equal? * module/language/tree-il/peval.scm: if an equality primitive is applied to the same variable twice, fold it to #t * test-suite/tests/tree-il.test: add tests for pevaling equality primitives
This commit is contained in:
parent
6978c67339
commit
3c65e3fda5
3 changed files with 31 additions and 1 deletions
|
@ -1103,6 +1103,17 @@ top-level bindings from ENV and return the resulting expression."
|
|||
((name . args)
|
||||
(fold-constants src name args ctx))))
|
||||
|
||||
(($ <primcall> src (? equality-primitive? name) (a b))
|
||||
(let ((val-a (for-value a))
|
||||
(val-b (for-value b)))
|
||||
(log 'equality-primitive name val-a val-b)
|
||||
(cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
|
||||
(eq? (lexical-ref-gensym val-a)
|
||||
(lexical-ref-gensym val-b)))
|
||||
(for-tail (make-const #f #t)))
|
||||
(else
|
||||
(fold-constants src name (list val-a val-b) ctx)))))
|
||||
|
||||
(($ <primcall> src (? effect-free-primitive? name) args)
|
||||
(fold-constants src name (map for-value args) ctx))
|
||||
|
||||
|
|
|
@ -29,7 +29,7 @@
|
|||
expand-primitives!
|
||||
effect-free-primitive? effect+exception-free-primitive?
|
||||
constructor-primitive? accessor-primitive?
|
||||
singly-valued-primitive?))
|
||||
singly-valued-primitive? equality-primitive?))
|
||||
|
||||
(define *interesting-primitive-names*
|
||||
'(apply @apply
|
||||
|
@ -206,9 +206,13 @@
|
|||
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
|
||||
f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
|
||||
|
||||
(define *equality-primitives*
|
||||
'(eq? eqv? equal?))
|
||||
|
||||
(define *effect-free-primitive-table* (make-hash-table))
|
||||
(define *effect+exceptions-free-primitive-table* (make-hash-table))
|
||||
(define *singly-valued-primitive-table* (make-hash-table))
|
||||
(define *equality-primitive-table* (make-hash-table))
|
||||
|
||||
(for-each (lambda (x)
|
||||
(hashq-set! *effect-free-primitive-table* x #t))
|
||||
|
@ -219,6 +223,9 @@
|
|||
(for-each (lambda (x)
|
||||
(hashq-set! *singly-valued-primitive-table* x #t))
|
||||
*singly-valued-primitives*)
|
||||
(for-each (lambda (x)
|
||||
(hashq-set! *equality-primitive-table* x #t))
|
||||
*equality-primitives*)
|
||||
|
||||
(define (constructor-primitive? prim)
|
||||
(memq prim *primitive-constructors*))
|
||||
|
@ -230,6 +237,8 @@
|
|||
(hashq-ref *effect+exceptions-free-primitive-table* prim))
|
||||
(define (singly-valued-primitive? prim)
|
||||
(hashq-ref *singly-valued-primitive-table* prim))
|
||||
(define (equality-primitive? prim)
|
||||
(hashq-ref *equality-primitive-table* prim))
|
||||
|
||||
(define (resolve-primitives! x mod)
|
||||
(define local-definitions
|
||||
|
|
|
@ -1498,6 +1498,16 @@
|
|||
;; Constant folding: cdr+list, impure
|
||||
(cdr (list (bar) 0))
|
||||
(seq (call (toplevel bar)) (primcall list (const 0))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Equality primitive: same lexical
|
||||
(let ((x (random))) (eq? x x))
|
||||
(seq (call (toplevel random)) (const #t)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Equality primitive: merge lexical identities
|
||||
(let* ((x (random)) (y x)) (eq? x y))
|
||||
(seq (call (toplevel random)) (const #t)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Non-constant guards get lexical bindings.
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue