[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp 7d07a71 3/4: Add sum/subtraction integer range propa
|
From: |
Andrea Corallo |
|
Subject: |
feature/native-comp 7d07a71 3/4: Add sum/subtraction integer range propagation support |
|
Date: |
Sun, 27 Dec 2020 15:53:39 -0500 (EST) |
branch: feature/native-comp
commit 7d07a718416d6c24df0719483279c4278dce4acb
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
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 d41501e..28cffcf 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 936e47f..336ed39 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 446c306..154229e 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)) ()