diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index b400c71a7..dd16709fd 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 -> (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?) - ($ _ _ sym) ($ _ _ sym)) - (for-tail (make-const #f #t))) + + (((? equality-primitive?) a (and b ($ _ 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 ($ )) b) + (for-tail (make-primcall src name (list b a)))) + (((? equality-primitive?) ($ _ _ sym) + ($ _ _ sym)) + (for-tail (make-const src #t))) (('logbit? ($ src2 (? (lambda (bit) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index f97da979b..b257aa17c 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=? . =))) - -;; 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=? . =))) + (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 3805259f0..366d5186e 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 863157a09..0fac528ac 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"))