mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
More robust reduction of equal? and eqv?
* module/language/tree-il/primitives.scm (expand-eq): Just expand out to
binary comparisons. Also expand eq?, which was missing. Leave
strength reduction to peval.
(character-comparison-expander): Move down, as it depends on <, <=,
and so on.
* module/language/tree-il/peval.scm (peval): Robustly reduce equal? and
eqv?.
* test-suite/tests/peval.test ("partial evaluation"): Expect fixnum
comparison to reduce to eq?.
("eqv?", "equal?"): A new battery of tests.
* test-suite/tests/tree-il.test ("primitives"): Remove reduction tests.
This commit is contained in:
Andy Wingo
parent
498428fbef
commit
7df3f3414b
4 changed files with 125 additions and 119 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;; Tree-IL partial evaluator
|
||||
|
||||
;; Copyright (C) 2011-2014, 2017, 2019 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2011-2014, 2017, 2019, 2020 Free Software Foundation, Inc.
|
||||
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -505,22 +505,14 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(define (apply-primitive name args)
|
||||
;; todo: further optimize commutative primitives
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(case name
|
||||
((eq? eqv?)
|
||||
;; Constants will be deduplicated later, but eq?
|
||||
;; folding can happen now. Anticipate the
|
||||
;; deduplication by using equal? instead of eq?.
|
||||
;; Same for eqv?.
|
||||
(apply equal? args))
|
||||
(else
|
||||
(apply (module-ref the-scm-module name) args))))
|
||||
(lambda results
|
||||
(values #t results))))
|
||||
(lambda _
|
||||
(values #f '()))))
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply (module-ref the-scm-module name) args))
|
||||
(lambda results
|
||||
(values #t results))))
|
||||
(lambda _
|
||||
(values #f '()))))
|
||||
(define (make-values src values)
|
||||
(match values
|
||||
((single) single) ; 1 value
|
||||
|
|
@ -710,7 +702,7 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(let loop ((exp exp)
|
||||
(env vlist-null) ; vhash of gensym -> <operand>
|
||||
(counter #f) ; inlined call stack
|
||||
(ctx 'values)) ; effect, value, values, test, operator, or call
|
||||
(ctx 'values)) ; effect, value, values, test, operator, or call
|
||||
(define (lookup var)
|
||||
(cond
|
||||
((vhash-assq var env) => cdr)
|
||||
|
|
@ -1348,9 +1340,39 @@ top-level bindings from ENV and return the resulting expression."
|
|||
(for-tail (make-seq src k (make-const #f #f))))
|
||||
(else
|
||||
(make-primcall src name (list k (make-const #f elts))))))))
|
||||
(((? equality-primitive?)
|
||||
($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
|
||||
(for-tail (make-const #f #t)))
|
||||
|
||||
(((? equality-primitive?) a (and b ($ <const> _ v)))
|
||||
(cond
|
||||
((const? a)
|
||||
;; Constants will be deduplicated later, but eq? folding can
|
||||
;; happen now. Anticipate the deduplication by using equal?
|
||||
;; instead of eq? or eqv?.
|
||||
(for-tail (make-const src (equal? (const-exp a) v))))
|
||||
((eq? name 'eq?)
|
||||
;; Already in a reduced state.
|
||||
(make-primcall src 'eq? (list a b)))
|
||||
((or (memq v '(#f #t () #nil)) (symbol? v) (char? v)
|
||||
(and (exact-integer? v)
|
||||
(<= most-negative-fixnum v most-positive-fixnum)))
|
||||
;; Reduce to eq?. Note that in Guile, characters are
|
||||
;; comparable with eq?.
|
||||
(make-primcall src 'eq? (list a b)))
|
||||
((number? v)
|
||||
;; equal? and eqv? on non-fixnum numbers is the same as
|
||||
;; eqv?, and can't be reduced beyond that.
|
||||
(make-primcall src 'eqv? (list a b)))
|
||||
((eq? name 'eqv?)
|
||||
;; eqv? on anything else is the same as eq?.
|
||||
(make-primcall src 'eq? (list a b)))
|
||||
(else
|
||||
;; FIXME: inline a specialized implementation of equal? for
|
||||
;; V here.
|
||||
(make-primcall src name (list a b)))))
|
||||
(((? equality-primitive?) (and a ($ <const>)) b)
|
||||
(for-tail (make-primcall src name (list b a))))
|
||||
(((? equality-primitive?) ($ <lexical-ref> _ _ sym)
|
||||
($ <lexical-ref> _ _ sym))
|
||||
(for-tail (make-const src #t)))
|
||||
|
||||
(('logbit? ($ <const> src2
|
||||
(? (lambda (bit)
|
||||
|
|
|
|||
|
|
@ -560,42 +560,11 @@
|
|||
(define-primitive-expander f64vector-set! (vec i x)
|
||||
(bytevector-ieee-double-native-set! vec (* i 8) x))
|
||||
|
||||
(define (character-comparison-expander char< <)
|
||||
(lambda (src . args)
|
||||
(expand-primcall
|
||||
(make-primcall src <
|
||||
(map (lambda (arg)
|
||||
(make-primcall src 'char->integer (list arg)))
|
||||
args)))))
|
||||
|
||||
(for-each (match-lambda
|
||||
((char< . <)
|
||||
(define-primitive-expander! char<
|
||||
(character-comparison-expander char< <))))
|
||||
'((char<? . <)
|
||||
(char>? . >)
|
||||
(char<=? . <=)
|
||||
(char>=? . >=)
|
||||
(char=? . =)))
|
||||
|
||||
;; Appropriate for use with either 'eqv?' or 'equal?'.
|
||||
(define (maybe-simplify-to-eq prim)
|
||||
(define (expand-eq prim)
|
||||
(case-lambda
|
||||
((src) (make-const src #t))
|
||||
((src a) (make-const src #t))
|
||||
((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)))
|
||||
(and (or (memq v '(#f #t () #nil))
|
||||
(symbol? v)
|
||||
(and (integer? v)
|
||||
(exact? v)
|
||||
(<= v most-positive-fixnum)
|
||||
(>= v most-negative-fixnum)))
|
||||
(make-primcall src 'eq? (list a b))))))
|
||||
(or (maybe-simplify a b) (maybe-simplify b a)))
|
||||
((src a b) #f)
|
||||
((src a b . rest)
|
||||
(with-lexicals src (b)
|
||||
(make-conditional src (make-primcall src prim (list a b))
|
||||
|
|
@ -603,8 +572,9 @@
|
|||
(make-const src #f))))
|
||||
(else #f)))
|
||||
|
||||
(define-primitive-expander! 'eqv? (maybe-simplify-to-eq 'eqv?))
|
||||
(define-primitive-expander! 'equal? (maybe-simplify-to-eq 'equal?))
|
||||
(define-primitive-expander! 'eq? (expand-eq 'eq?))
|
||||
(define-primitive-expander! 'eqv? (expand-eq 'eqv?))
|
||||
(define-primitive-expander! 'equal? (expand-eq 'equal?))
|
||||
|
||||
(define (expand-chained-comparisons prim)
|
||||
(case-lambda
|
||||
|
|
@ -628,6 +598,24 @@
|
|||
(expand-chained-comparisons prim)))
|
||||
'(< <= = >= > eq?))
|
||||
|
||||
(define (character-comparison-expander char< <)
|
||||
(lambda (src . args)
|
||||
(expand-primcall
|
||||
(make-primcall src <
|
||||
(map (lambda (arg)
|
||||
(make-primcall src 'char->integer (list arg)))
|
||||
args)))))
|
||||
|
||||
(for-each (match-lambda
|
||||
((char< . <)
|
||||
(define-primitive-expander! char<
|
||||
(character-comparison-expander char< <))))
|
||||
'((char<? . <)
|
||||
(char>? . >)
|
||||
(char<=? . <=)
|
||||
(char>=? . >=)
|
||||
(char=? . =)))
|
||||
|
||||
(define-primitive-expander! 'call-with-prompt
|
||||
(case-lambda
|
||||
((src tag thunk handler)
|
||||
|
|
|
|||
|
|
@ -642,11 +642,11 @@
|
|||
((3 2 1) 'a)
|
||||
(else 'b))
|
||||
(let (key) (_) ((toplevel foo))
|
||||
(if (if (primcall eqv? (lexical key _) (const 3))
|
||||
(if (if (primcall eq? (lexical key _) (const 3))
|
||||
(const #t)
|
||||
(if (primcall eqv? (lexical key _) (const 2))
|
||||
(if (primcall eq? (lexical key _) (const 2))
|
||||
(const #t)
|
||||
(primcall eqv? (lexical key _) (const 1))))
|
||||
(primcall eq? (lexical key _) (const 1))))
|
||||
(const a)
|
||||
(const b))))
|
||||
|
||||
|
|
@ -1441,3 +1441,59 @@
|
|||
(call (lexical add1 _)
|
||||
(const 1)
|
||||
(const 2))))))))
|
||||
|
||||
(with-test-prefix "eqv?"
|
||||
(pass-if-peval (eqv? x #f)
|
||||
(primcall eq? (toplevel x) (const #f)))
|
||||
|
||||
(pass-if-peval (eqv? x '())
|
||||
(primcall eq? (toplevel x) (const ())))
|
||||
|
||||
(pass-if-peval (eqv? x #t)
|
||||
(primcall eq? (toplevel x) (const #t)))
|
||||
|
||||
(pass-if-peval (eqv? x 'sym)
|
||||
(primcall eq? (toplevel x) (const sym)))
|
||||
|
||||
(pass-if-peval (eqv? x 42)
|
||||
(primcall eq? (toplevel x) (const 42)))
|
||||
|
||||
(pass-if-peval (eqv? x #\a)
|
||||
(primcall eq? (toplevel x) (const #\a)))
|
||||
|
||||
(pass-if-peval (eqv? x 42.0)
|
||||
(primcall eqv? (toplevel x) (const '42.0)))
|
||||
|
||||
(pass-if-peval (eqv? x #nil)
|
||||
(primcall eq? (toplevel x) (const #nil)))
|
||||
|
||||
(pass-if-peval (eqv? x '(a . b))
|
||||
(primcall eq? (toplevel x) (const (a . b)))))
|
||||
|
||||
(with-test-prefix "equal?"
|
||||
(pass-if-peval (equal? x #f)
|
||||
(primcall eq? (toplevel x) (const #f)))
|
||||
|
||||
(pass-if-peval (equal? x '())
|
||||
(primcall eq? (toplevel x) (const ())))
|
||||
|
||||
(pass-if-peval (equal? x #t)
|
||||
(primcall eq? (toplevel x) (const #t)))
|
||||
|
||||
(pass-if-peval (equal? x 'sym)
|
||||
(primcall eq? (toplevel x) (const sym)))
|
||||
|
||||
(pass-if-peval (equal? x 42)
|
||||
(primcall eq? (toplevel x) (const 42)))
|
||||
|
||||
(pass-if-peval (equal? x #\a)
|
||||
(primcall eq? (toplevel x) (const #\a)))
|
||||
|
||||
(pass-if-peval (equal? x 42.0)
|
||||
(primcall eqv? (toplevel x) (const '42.0)))
|
||||
|
||||
(pass-if-peval (equal? x #nil)
|
||||
(primcall eq? (toplevel x) (const #nil)))
|
||||
|
||||
(pass-if-peval (equal? x '(a . b))
|
||||
(primcall equal? (toplevel x) (const (a . b)))))
|
||||
|
|
|
|||
|
|
@ -56,66 +56,6 @@
|
|||
|
||||
(with-test-prefix "primitives"
|
||||
|
||||
(with-test-prefix "eqv?"
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (toplevel x) (const #f))
|
||||
(primcall eq? (const #f) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (toplevel x) (const ()))
|
||||
(primcall eq? (const ()) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (const #t) (lexical x y))
|
||||
(primcall eq? (const #t) (lexical x y)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (const this-is-a-symbol) (toplevel x))
|
||||
(primcall eq? (const this-is-a-symbol) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (const 42) (toplevel x))
|
||||
(primcall eq? (const 42) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (const 42.0) (toplevel x))
|
||||
(primcall eqv? (const 42.0) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall eqv? (const #nil) (toplevel x))
|
||||
(primcall eq? (const #nil) (toplevel x))))
|
||||
|
||||
(with-test-prefix "equal?"
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (toplevel x) (const #f))
|
||||
(primcall eq? (const #f) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (toplevel x) (const ()))
|
||||
(primcall eq? (const ()) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (const #t) (lexical x y))
|
||||
(primcall eq? (const #t) (lexical x y)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (const this-is-a-symbol) (toplevel x))
|
||||
(primcall eq? (const this-is-a-symbol) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (const 42) (toplevel x))
|
||||
(primcall eq? (const 42) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (const 42.0) (toplevel x))
|
||||
(primcall equal? (const 42.0) (toplevel x)))
|
||||
|
||||
(pass-if-primitives-resolved
|
||||
(primcall equal? (const #nil) (toplevel x))
|
||||
(primcall eq? (const #nil) (toplevel x))))
|
||||
|
||||
(with-test-prefix "error"
|
||||
(pass-if-primitives-resolved
|
||||
(primcall error (const "message"))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue