From 7d07a718416d6c24df0719483279c4278dce4acb Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sun, 27 Dec 2020 14:07:08 +0100 Subject: [PATCH] Add sum/subtraction integer range propagation support * lisp/emacs-lisp/comp-cstr.el (comp-range-+, comp-range--): New functions. (comp-cstr-set-range-for-arithm): New macro. (comp-cstr-add-2, comp-cstr-sub-2, comp-cstr-add, comp-cstr-sub): New function. * lisp/emacs-lisp/comp.el (comp-fwprop-call): Wire-up + - integer range propagation. --- lisp/emacs-lisp/comp-cstr.el | 63 +++++++++++++++++++++++++ lisp/emacs-lisp/comp.el | 5 +- test/src/comp-tests.el | 91 +++++++++++++++++++++++++++++++++++- 3 files changed, 157 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d41501e6804..28cffcf0661 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -280,6 +280,22 @@ Return them as multiple value." x (1- x))) +(defsubst comp-range-+ (x y) + (pcase (cons x y) + ((or '(+ . -) '(- . +)) '??) + ((or `(- . ,_) `(,_ . -)) '-) + ((or `(+ . ,_) `(,_ . +)) '+) + (_ (+ x y)))) + +(defsubst comp-range-- (x y) + (pcase (cons x y) + ((or '(+ . +) '(- . -)) '??) + ('(+ . -) '+) + ('(- . +) '-) + ((or `(+ . ,_) `(,_ . -)) '+) + ((or `(- . ,_) `(,_ . +)) '-) + (_ (- x y)))) + (defsubst comp-range-< (x y) (cond ((eq x '+) nil) @@ -389,6 +405,39 @@ Return them as multiple value." (range dst) (range old-dst) (neg dst) (neg old-dst))))) +(defmacro comp-cstr-set-range-for-arithm (dst src1 src2 &rest range-body) + ;; Prevent some code duplication for `comp-cstr-add-2' + ;; `comp-cstr-sub-2'. + (declare (debug (range-body)) + (indent defun)) + `(with-comp-cstr-accessors + (when-let ((r1 (range ,src1)) + (r2 (range ,src2))) + (let* ((l1 (comp-cstr-smallest-in-range r1)) + (l2 (comp-cstr-smallest-in-range r2)) + (h1 (comp-cstr-greatest-in-range r1)) + (h2 (comp-cstr-greatest-in-range r2))) + (setf (typeset ,dst) (when (cl-some (lambda (x) + (comp-subtype-p 'float x)) + (append (typeset src1) + (typeset src2))) + '(float)) + (range ,dst) ,@range-body))))) + +(defun comp-cstr-add-2 (dst src1 src2) + "Sum SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + `((,(comp-range-+ l1 l2) . ,(comp-range-+ h1 h2))))) + +(defun comp-cstr-sub-2 (dst src1 src2) + "Subtract SRC1 and SRC2 into DST." + (comp-cstr-set-range-for-arithm dst src1 src2 + (let ((l (comp-range-- l1 h2)) + (h (comp-range-- h1 l2))) + (if (or (eq l '??) (eq h '??)) + '((- . +)) + `((,l . ,h)))))) + ;;; Union specific code. @@ -742,6 +791,20 @@ SRC can be either a comp-cstr or an integer." `((- . ,low)))))) (comp-cstr-set-cmp-range dst old-dst ext-range)))) +(defun comp-cstr-add (dst srcs) + "Sum SRCS into DST." + (comp-cstr-add-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-add-2 dst dst src))) + +(defun comp-cstr-sub (dst srcs) + "Subtract SRCS into DST." + (comp-cstr-sub-2 dst (cl-first srcs) (cl-second srcs)) + (cl-loop + for src in (nthcdr 2 srcs) + do (comp-cstr-sub-2 dst dst src))) + (defun comp-cstr-union-no-range (dst &rest srcs) "Combine SRCS by union set operation setting the result in DST. Do not propagate the range component. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 936e47ff39a..336ed39145d 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -2648,7 +2648,10 @@ Fold the call in case." (setf (comp-mvar-range lval) (comp-cstr-range cstr) (comp-mvar-valset lval) (comp-cstr-valset cstr) (comp-mvar-typeset lval) (comp-cstr-typeset cstr) - (comp-mvar-neg lval) (comp-cstr-neg cstr)))))) + (comp-mvar-neg lval) (comp-cstr-neg cstr)))) + (cl-case f + (+ (comp-cstr-add lval args)) + (- (comp-cstr-sub lval args))))) (defun comp-fwprop-insn (insn) "Propagate within INSN." diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 446c30666f0..154229ec872 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -1036,7 +1036,96 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (when (> x 1.0) x)) - (or null marker number)))) + (or null marker number)) + + ;; 36 + ;; SBCL: (OR (RATIONAL (5)) (SINGLE-FLOAT 5.0) + ;; (DOUBLE-FLOAT 5.0d0) NULL) !? + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (> x 3) + (> y 2)) + (+ x y))) + (or null float (integer 7 *))) + + ;; 37 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 3) + (<= y 2)) + (+ x y))) + (or null float (integer * 5))) + + ;; 38 SBCL gives: (OR (RATIONAL (2) (10)) (SINGLE-FLOAT 2.0 10.0) + ;; (DOUBLE-FLOAT 2.0d0 10.0d0) NULL)!? + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (< 1 x 5) + (< 1 y 5)) + (+ x y))) + (or null float (integer 4 8))) + + ;; 37 + ;; SBCL gives: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) + (or null float (integer 3 13))) + + ;; 38 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 8))) + + ;; 39 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 *))) + + ;; 40 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 41 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 42 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= y 3)) + (- x y))) + (or null float integer)) + + ;; 43 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) + (or null float integer)) + + ;; 44 + ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) + ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) + ((defun comp-tests-ret-type-spec-f (x y z i j k) + (when (and (< 1 x 5) + (< 1 y 5) + (< 1 z 5) + (< 1 i 5) + (< 1 j 5) + (< 1 k 5)) + (+ x y z i j k))) + (or null float (integer 12 24))))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () -- 2.39.5