feature/native-comp 89d5a3a: Enable integer range narrowing under compare and branch

[Andrea Corallo]

branch: feature/native-comp
commit 89d5a3a7603a0b096d02f58ba0a1997ad98c63ae
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    Enable integer range narrowing under compare and branch
    
        * lisp/emacs-lisp/comp-cstr.el (comp-cstr-set-cmp-range)
        (comp-cstr->, comp-cstr->=, comp-cstr-<, comp-cstr-<=): New
        functions.
        * lisp/emacs-lisp/comp.el (comp-equality-fun-p)
        (comp-range-cmp-fun-p): New functions.
        (comp-collect-rhs): Use `comp-assign-op-p' in place of
        `comp-set-op-p'.
        (comp-negate-range-cmp-fun, comp-reverse-cmp-fun): New functions.
        (comp-emit-assume): Rework to be able to emit also comparision
        assumption.
        (comp-add-cond-cstrs-simple): Update for new `comp-emit-assume'.
        (comp-add-cond-cstrs-simple): Update to emit range assumption.
        (comp-fwprop-insn): Execute range assumptions.
        * test/src/comp-tests.el (comp-tests-type-spec-tests): Add tests.
---
 lisp/emacs-lisp/comp-cstr.el |  68 +++++++++++++++++++++++++++++
 lisp/emacs-lisp/comp.el      | 102 +++++++++++++++++++++++++++++++++----------
 test/src/comp-tests.el       |  77 +++++++++++++++++++++++++++++++-
 3 files changed, 224 insertions(+), 23 deletions(-)

diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 32989f2..9d0c671 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -362,6 +362,22 @@ Return them as multiple value."
        (push `(,(1+ last-h) . +) res))
      (cl-return (reverse res)))))
 
+(defsubst comp-cstr-set-cmp-range (dst old-dst ext-range)
+  "Support range comparison functions."
+  (with-comp-cstr-accessors
+    (if ext-range
+        (setf (typeset dst) ()
+              (valset dst) ()
+              (range dst) (if (range old-dst)
+                              (comp-range-intersection (range old-dst)
+                                                       ext-range)
+                            ext-range)
+              (neg dst) nil)
+      (setf (typeset dst) (typeset old-dst)
+            (valset dst) (valset old-dst)
+            (range dst) (range old-dst)
+            (neg dst) (neg old-dst)))))
+
 
 ;;; Union specific code.
 
@@ -663,6 +679,58 @@ Non memoized version of `comp-cstr-intersection-no-mem'."
 
 ;;; Entry points.
 
+(defun comp-cstr-> (dst old-dst src)
+  "Constraint DST being > than SRC.
+SRC can be either a comp-cstr or an integer."
+  (with-comp-cstr-accessors
+    (let ((ext-range
+           (if (integerp src)
+               `((,(1+ src) . +))
+             (when-let* ((range (range src))
+                         (low (cdar (last range)))
+                         (okay (integerp low)))
+               `((,(1+ low) . +))))))
+      (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr->= (dst old-dst src)
+  "Constraint DST being >= than SRC.
+SRC can be either a comp-cstr or an integer."
+  (with-comp-cstr-accessors
+    (let ((ext-range
+           (if (integerp src)
+               `((,src . +))
+             (when-let* ((range (range src))
+                         (low (cdar (last range)))
+                         (okay (integerp low)))
+               `((,low . +))))))
+      (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-< (dst old-dst src)
+  "Constraint DST being < than SRC.
+SRC can be either a comp-cstr or an integer."
+  (with-comp-cstr-accessors
+    (let ((ext-range
+           (if (integerp src)
+               `((- . ,(1- src)))
+             (when-let* ((range (range src))
+                         (low (caar (last range)))
+                         (okay (integerp low)))
+               `((- . ,(1- low)))))))
+      (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
+(defun comp-cstr-<= (dst old-dst src)
+  "Constraint DST being > than SRC.
+SRC can be either a comp-cstr or an integer."
+  (with-comp-cstr-accessors
+    (let ((ext-range
+           (if (integerp src)
+               `((- . ,src))
+             (when-let* ((range (range src))
+                         (low (caar (last range)))
+                         (okay (integerp low)))
+               `((- . ,low))))))
+      (comp-cstr-set-cmp-range dst old-dst ext-range))))
+
 (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 1804f1f..7d444af 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -597,6 +597,14 @@ To be used by all entry points."
    ((null (native-comp-available-p))
     (error "Cannot find libgccjit"))))
 
+(defun comp-equality-fun-p (function)
+  "Equality functions predicate for FUNCTION."
+  (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-set-op-p (op)
   "Assignment predicate for OP."
   (when (memq op comp-limple-sets) t))
@@ -1876,7 +1884,10 @@ into the C code forwarding the compilation unit."
 ;; generated from:
 ;;
 ;;  - Conditional branches: each branch taken or non taken can be used
-;;    in the CFG to infer infomations on the tested variables.
+;;    in the CFG to infer information on the tested variables.
+;;
+;;  - Range propagation under test and branch (when the test is an
+;;    arithmetic comparison.)
 ;;
 ;;  - Function calls: function calls to function assumed to be not
 ;;    redefinable can be used to add constrains on the function
@@ -1907,25 +1918,58 @@ into the C code forwarding the compilation unit."
    do (cl-loop
        for insn in (comp-block-insns b)
        for (op . args) = insn
-       if  (comp-set-op-p op)
+       if (comp-assign-op-p op)
          do (comp-collect-mvars (cdr args))
        else
          do (comp-collect-mvars args))))
 
-(defun comp-emit-assume (lhs rhs bb negated)
-  "Emit an assume for mvar LHS being RHS.
+(defun comp-negate-range-cmp-fun (function)
+  "Negate FUNCTION."
+  (cl-ecase function
+    (> '<=)
+    (< '>=)
+    (>= '<)
+    (<= '>)))
+
+(defun comp-reverse-cmp-fun (function)
+  "Reverse FUNCTION."
+  (cl-case function
+    (> '<)
+    (< '>)
+    (>= '<=)
+    (<= '>=)
+    (t function)))
+
+(defun comp-emit-assume (kind lhs rhs bb negated)
+  "Emit an assume of kind KIND for mvar LHS being RHS.
 When NEGATED is non-nil the assumption is negated.
 The assume is emitted at the beginning of the block BB."
-  (let ((lhs-slot (comp-mvar-slot lhs))
-        (tmp-mvar (if negated
-                      (make-comp-mvar :slot (comp-mvar-slot rhs))
-                    rhs)))
+  (let ((lhs-slot (comp-mvar-slot lhs)))
     (cl-assert lhs-slot)
-    (push `(assume ,(make-comp-mvar :slot lhs-slot) (and ,lhs ,tmp-mvar))
-         (comp-block-insns bb))
-    (if negated
-        (push `(assume ,tmp-mvar (not ,rhs))
-             (comp-block-insns bb)))
+    (pcase kind
+      ('and
+       (let ((tmp-mvar (if negated
+                          (make-comp-mvar :slot (comp-mvar-slot rhs))
+                        rhs)))
+         (push `(assume ,(make-comp-mvar :slot lhs-slot)
+                        (and ,lhs ,tmp-mvar))
+              (comp-block-insns bb))
+         (if negated
+             (push `(assume ,tmp-mvar (not ,rhs))
+                  (comp-block-insns bb)))))
+      ((pred comp-range-cmp-fun-p)
+       (let ((kind (if negated
+                       (comp-negate-range-cmp-fun kind)
+                     kind)))
+         (push `(assume ,(make-comp-mvar :slot lhs-slot)
+                        (,kind ,lhs
+                               ,(if-let* ((vld (comp-mvar-value-vld-p rhs))
+                                          (val (comp-mvar-value rhs))
+                                          (ok (integerp val)))
+                                    val
+                                  (make-comp-mvar :slot (comp-mvar-slot 
rhs)))))
+              (comp-block-insns bb))))
+      (_ (cl-assert nil)))
     (setf (comp-func-ssa-status comp-func) 'dirty)))
 
 (defun comp-add-new-block-between (bb-symbol bb-a bb-b)
@@ -2012,7 +2056,7 @@ TARGET-BB-SYM is the symbol name of the target block."
         do
        (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
           (setf (car branch-target-cell) (comp-block-name block-target))
-          (comp-emit-assume tmp-mvar obj2 block-target negated))
+          (comp-emit-assume 'and tmp-mvar obj2 block-target negated))
         finally (cl-return-from in-the-basic-block)))
       (`((cond-jump ,obj1 ,obj2 . ,blocks))
        (cl-loop
@@ -2023,7 +2067,7 @@ TARGET-BB-SYM is the symbol name of the target block."
         do
        (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
           (setf (car branch-target-cell) (comp-block-name block-target))
-          (comp-emit-assume obj1 obj2 block-target negated))
+          (comp-emit-assume 'and obj1 obj2 block-target negated))
         finally (cl-return-from in-the-basic-block)))))))
 
 (defun comp-add-cond-cstrs ()
@@ -2036,26 +2080,32 @@ TARGET-BB-SYM is the symbol name of the target block."
     for insns-seq on (comp-block-insns b)
     do
     (pcase insns-seq
-      (`((set ,(and (pred comp-mvar-p) obj1)
+      (`((set ,(and (pred comp-mvar-p) cmp-res)
               (,(pred comp-call-op-p)
-               ,(or 'eq 'eql '= 'equal) ,op1 ,op2))
+               ,(and (or (pred comp-equality-fun-p)
+                         (pred comp-range-cmp-fun-p))
+                     fun)
+               ,op1 ,op2))
         ;; (comment ,_comment-str)
-        (cond-jump ,obj1 ,(pred comp-mvar-p) . ,blocks))
+        (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
        (cl-loop
         with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b)
         with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b)
+        with equality = (comp-equality-fun-p fun)
         for branch-target-cell on blocks
         for branch-target = (car branch-target-cell)
         for negated in '(t nil)
+        for kind = (if equality 'and fun)
         when (or (comp-mvar-used-p target-mvar1)
                  (comp-mvar-used-p target-mvar2))
         do
         (let ((block-target (comp-add-cond-cstrs-target-block b 
branch-target)))
           (setf (car branch-target-cell) (comp-block-name block-target))
           (when (comp-mvar-used-p target-mvar1)
-            (comp-emit-assume target-mvar1 op2 block-target negated))
+            (comp-emit-assume kind target-mvar1 op2 block-target negated))
           (when (comp-mvar-used-p target-mvar2)
-            (comp-emit-assume target-mvar2 op1 block-target negated)))
+            (comp-emit-assume (comp-reverse-cmp-fun kind)
+                              target-mvar2 op1 block-target negated)))
         finally (cl-return-from in-the-basic-block)))))))
 
 (defun comp-emit-call-cstr (mvar call-cell cstr)
@@ -2610,13 +2660,21 @@ Fold the call in case."
        (_
         (comp-mvar-propagate lval rval))))
     (`(assume ,lval (,kind . ,operands))
-     (cl-ecase kind
+     (cl-case kind
        (and
         (apply #'comp-cstr-intersection lval operands))
        (not
         ;; Prevent double negation!
         (unless (comp-cstr-neg (car operands))
-          (comp-cstr-value-negation lval (car operands))))))
+          (comp-cstr-value-negation lval (car operands))))
+       (>
+        (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-mvar-value lval) v))
     (`(phi ,lval . ,rest)
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 8f0b340..22065f8 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -947,7 +947,82 @@ Return a list of results."
       ((defun comp-tests-ret-type-spec-f (x)
          (unless x
            'foo))
-       (or (member foo) null))))
+       (or (member foo) null))
+
+      ;; 22
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (> x 3)
+           x))
+       (or null (integer 4 *)))
+
+      ;; 23
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (>= x 3)
+           x))
+       (or null (integer 3 *)))
+
+      ;; 24
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (< x 3)
+           x))
+       (or null (integer * 2)))
+
+      ;; 25
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (<= x 3)
+           x))
+       (or null (integer * 3)))
+
+      ;; 26
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (> 3 x)
+           x))
+       (or null (integer * 2)))
+
+      ;; 27
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (>= 3 x)
+           x))
+       (or null (integer * 3)))
+
+      ;; 28
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (< 3 x)
+           x))
+       (or null (integer 4 *)))
+
+      ;; 29
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (<= 3 x)
+           x))
+       (or null (integer 3 *)))
+
+      ;; 30
+      ((defun comp-tests-ret-type-spec-f (x)
+         (let ((y 3))
+          (when (> x y)
+            x)))
+       (or null (integer 4 *)))
+
+      ;; 31
+      ((defun comp-tests-ret-type-spec-f (x)
+         (let ((y 3))
+          (when (> y x)
+            x)))
+       (or null (integer * 2)))
+
+      ;; 32
+      ((defun comp-tests-ret-type-spec-f (x)
+         (when (and (> x 3)
+                   (< x 10))
+          x))
+       (or null (integer 4 9)))
+
+      ;; 33 No float range support.
+      ((defun comp-tests-ret-type-spec-f (x)
+              (when (> x 1.0)
+                x))
+       (or null marker number))))
 
   (defun comp-tests-define-type-spec-test (number x)
     `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()