From 5bc08559e8f171eafc3c034232f8cfd9eaf89862 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 27 Feb 2021 22:00:11 +0100 Subject: [PATCH] Don't treat '=' as simple equality emitting constraints (bug#46812) Extend assumes allowing the following form (assume dst (= src1 src2)) to caputure '=' semanting during fwprop handling float integer conversions. * lisp/emacs-lisp/comp.el (comp-equality-fun-p): Don't treat '=' as simple equality. (comp-arithm-cmp-fun-p, comp-negate-arithm-cmp-fun) (comp-reverse-arithm-fun): Rename and add '=' '!='. (comp-emit-assume, comp-add-cond-cstrs, comp-fwprop-insn): Update for new function nameing and to handle '='. * lisp/emacs-lisp/comp-cstr.el (comp-cstr-=): New function. * test/src/comp-tests.el (comp-tests-type-spec-tests): Add a bunch of '=' specific tests. --- lisp/emacs-lisp/comp-cstr.el | 12 +++++++++ lisp/emacs-lisp/comp.el | 37 ++++++++++++++++------------ test/src/comp-tests.el | 47 +++++++++++++++++++++++++++++++----- 3 files changed, 75 insertions(+), 21 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 89815f03b53..bd1e04fb0bb 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -859,6 +859,18 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +(defun comp-cstr-= (dst old-dst src) + "Constraint DST being = SRC." + (with-comp-cstr-accessors + (comp-cstr-intersection dst old-dst src) + (cl-loop for v in (valset dst) + when (and (floatp v) + (= v (truncate v))) + do (push (cons (truncate v) (truncate v)) (range dst))) + (cl-loop for (l . h) in (range dst) + when (eql l h) + do (push (float l) (valset dst))))) + (defun comp-cstr-> (dst old-dst src) "Constraint DST being > than SRC. SRC can be either a comp-cstr or an integer." diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index e71d4abbd53..03999d3e66f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -906,11 +906,11 @@ To be used by all entry points." (defun comp-equality-fun-p (function) "Equality functions predicate for FUNCTION." - (when (memq function '(eq eql = equal)) t)) + (when (memq function '(eq eql equal)) t)) -(defun comp-range-cmp-fun-p (function) - "Predicate for range comparision functions." - (when (memq function '(> < >= <=)) t)) +(defun comp-arithm-cmp-fun-p (function) + "Predicate for arithmetic comparision functions." + (when (memq function '(= > < >= <=)) t)) (defun comp-set-op-p (op) "Assignment predicate for OP." @@ -2238,17 +2238,21 @@ into the C code forwarding the compilation unit." else do (comp-collect-mvars args)))) -(defun comp-negate-range-cmp-fun (function) - "Negate FUNCTION." +(defun comp-negate-arithm-cmp-fun (function) + "Negate FUNCTION. +Return nil if we don't want to emit constraints for its +negation." (cl-ecase function + (= nil) (> '<=) (< '>=) (>= '<) (<= '>))) -(defun comp-reverse-cmp-fun (function) +(defun comp-reverse-arithm-fun (function) "Reverse FUNCTION." (cl-case function + (= '=) (> '<) (< '>) (>= '<=) @@ -2279,15 +2283,16 @@ The assume is emitted at the beginning of the block BB." (comp-cstr-negation-make rhs) rhs))) (comp-block-insns bb)))) - ((pred comp-range-cmp-fun-p) - (let ((kind (if negated - (comp-negate-range-cmp-fun kind) - kind))) + ((pred comp-arithm-cmp-fun-p) + (when-let ((kind (if negated + (comp-negate-arithm-cmp-fun kind) + kind))) (push `(assume ,(make-comp-mvar :slot lhs-slot) (,kind ,lhs ,(if-let* ((vld (comp-cstr-imm-vld-p rhs)) (val (comp-cstr-imm rhs)) - (ok (integerp val))) + (ok (and (integerp val) + (not (memq kind '(= !=)))))) val (make-comp-mvar :slot (comp-mvar-slot rhs))))) (comp-block-insns bb)))) @@ -2418,7 +2423,7 @@ TARGET-BB-SYM is the symbol name of the target block." (`((set ,(and (pred comp-mvar-p) cmp-res) (,(pred comp-call-op-p) ,(and (or (pred comp-equality-fun-p) - (pred comp-range-cmp-fun-p)) + (pred comp-arithm-cmp-fun-p)) fun) ,op1 ,op2)) ;; (comment ,_comment-str) @@ -2441,7 +2446,7 @@ TARGET-BB-SYM is the symbol name of the target block." (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq) block-target negated)) (when (comp-mvar-used-p target-mvar2) - (comp-emit-assume (comp-reverse-cmp-fun kind) + (comp-emit-assume (comp-reverse-arithm-fun kind) target-mvar2 (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq) block-target negated))) @@ -3108,7 +3113,9 @@ Fold the call in case." (< (comp-cstr-< lval (car operands) (cadr operands))) (<= - (comp-cstr-<= lval (car operands) (cadr operands))))) + (comp-cstr-<= lval (car operands) (cadr operands))) + (= + (comp-cstr-= lval (car operands) (cadr operands))))) (`(setimm ,lval ,v) (setf (comp-cstr-imm lval) v)) (`(phi ,lval . ,rest) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 402ba7cd8b8..0598eeeb05d 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -891,24 +891,24 @@ Return a list of results." ;; 10 ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) + (if (eql x 3) x 'foo)) (or (member foo) (integer 3 3))) ;; 11 ((defun comp-tests-ret-type-spec-f (x) - (if (= 3 x) + (if (eql 3 x) x 'foo)) (or (member foo) (integer 3 3))) ;; 12 ((defun comp-tests-ret-type-spec-f (x) - (if (= x 3) + (if (eql x 3) 'foo x)) - (or (member foo) marker number)) + (not (integer 3 3))) ;; 13 ((defun comp-tests-ret-type-spec-f (x y) @@ -1214,7 +1214,7 @@ Return a list of results." ;; 57 ((defun comp-tests-ret-type-spec-f (x) (unless (or (eq x 'foo) - (= x 3)) + (eql x 3)) (error "Not foo or 3")) x) (or (member foo) (integer 3 3))) @@ -1244,7 +1244,42 @@ Return a list of results." (>= x y)) x (error ""))) - (or float (integer 3 10))))) + (or float (integer 3 10))) + + ;; 61 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 62 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 63 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.1) + x + (error ""))) + (member 1.1)) + + ;; 64 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 65 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () -- 2.39.2