[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: More robust reduction of equal? and eqv?
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/02: More robust reduction of equal? and eqv? |
|
Date: |
Wed, 13 May 2020 09:54:50 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 7df3f3414bfb19a1bd7fbe29bc30a1ab28bf4319
Author: Andy Wingo <address@hidden>
AuthorDate: Wed May 13 15:51:58 2020 +0200
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.
---
module/language/tree-il/peval.scm | 64 +++++++++++++++++++++++-----------
module/language/tree-il/primitives.scm | 58 ++++++++++++------------------
test-suite/tests/peval.test | 62 ++++++++++++++++++++++++++++++--
test-suite/tests/tree-il.test | 60 -------------------------------
4 files changed, 125 insertions(+), 119 deletions(-)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index b400c71..dd16709 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -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)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index f97da97..b257aa1 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -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)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 3805259..366d518 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -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)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 863157a..0fac528 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -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"))