Add initial nativecomp typeset and range propagation support

This commit add an initial support for a better type propagation and
integer range propagation.

Each mvar can be now characterized by a set of types, a set of values
and an integral range.

	* lisp/emacs-lisp/comp.el (comp-known-ret-types): Store into
	typeset and remove fixnum.
	(comp-known-ret-ranges, comp-type-predicates): New variables.
	(comp-ctxt): Remove supertype-memoize slot and add
	union-typesets-mem.
	(comp-mvar): Remove const-vld, constant, type slots. Add typeset,
	valset, range slots.
	(comp-mvar-value-vld-p, comp-mvar-value, comp-mvar-fixnum-p)
	(comp-mvar-symbol-p, comp-mvar-cons-p)
	(comp-mvar-type-hint-match-p, comp-func-ret-typeset)
	(comp-func-ret-range): New functions.
	(make-comp-mvar, make-comp-ssa-mvar): Update logic.
	(comp--typeof-types): New variable.
	(comp-supertypes, comp-common-supertype): Logic update.
	(comp-subtype-p, comp-union-typesets, comp-range-1+)
	(comp-range-1-, comp-range-<, comp-range-union)
	(comp-range-intersection): New functions.
	(comp-fwprop-prologue, comp-mvar-propagate)
	(comp-function-foldable-p, comp-function-call-maybe-fold)
	(comp-fwprop-insn, comp-call-optim-func, comp-finalize-relocs):
	Logic update.

	* src/comp.c (emit_mvar_rval, emit_call_with_type_hint)
	(emit_call2_with_type_hint): Logic update.

	* lisp/emacs-lisp/cl-preloaded.el (cl--typeof-types): Undo the add
	of fixnum and bignum as unnecessary.

	* test/src/comp-tests.el
	(comp-tests-mentioned-p-1, comp-tests-cond-rw-checker-val)
	(comp-tests-cond-rw-checker-type, cond-rw-1, cond-rw-2)
	(cond-rw-3, cond-rw-4, cond-rw-5): Update for new type interface.
	(range-simple-union, range-simple-intersection): New integer range
	tests.
	(union-types): New union type test.

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index b5dbcbda473f31e71d6bf6a5aa9d87766415b43e..eed43c5ed38233ca6bcfa9cf18f7113f353929e8 100644 (file)
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -52,8 +52,7 @@
 
 (defconst cl--typeof-types
   ;; Hand made from the source code of `type-of'.
-  '((fixnum integer number number-or-marker atom)
-    (bignum integer number number-or-marker atom)
+  '((integer number number-or-marker atom)
     (symbol atom) (string array sequence atom)
     (cons list sequence)
     ;; Markers aren't `numberp', yet they are accepted wherever integers are

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 8bee8afeacf8904bd949c3de812ab724941e3d03..ad0ac21389e28251b3d19866ca92ad8261707d4e 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -191,19 +191,31 @@ For internal use only by the testsuite.")
 Each function in FUNCTIONS is run after PASS.
 Useful to hook into pass checkers.")
 
-(defconst comp-known-ret-types '((cons . cons)
-                                 (1+ . number)
-                                 (1- . number)
-                                 (+ . number)
-                                 (- . number)
-                                 (* . number)
-                                 (/ . number)
-                                 (% . number)
+(defconst comp-known-ret-types '((cons . (cons))
+                                 (1+ . (number))
+                                 (1- . (number))
+                                 (+ . (number))
+                                 (- . (number))
+                                 (* . (number))
+                                 (/ . (number))
+                                 (% . (number))
                                  ;; Type hints
-                                 (comp-hint-fixnum . fixnum)
-                                 (comp-hint-cons . cons))
+                                 (comp-hint-cons . (cons)))
   "Alist used for type propagation.")
 
+(defconst comp-known-ret-ranges
+  `((comp-hint-fixnum . (,most-negative-fixnum . ,most-positive-fixnum)))
+  "Known returned ranges.")
+
+;; TODO fill it.
+(defconst comp-type-predicates '((cons . consp)
+                                 (float . floatp)
+                                 (integer . integerp)
+                                 (number . numberp)
+                                 (string . stringp)
+                                 (symbol . symbolp))
+  "Alist type -> predicate.")
+
 (defconst comp-symbol-values-optimizable '(most-positive-fixnum
                                            most-negative-fixnum)
   "Symbol values we can resolve in the compile-time.")
@@ -285,9 +297,9 @@ This is tipically for top-level forms other than defun.")
                :documentation "Relocated data not necessary after load.")
   (with-late-load nil :type boolean
                   :documentation "When non-nil support late load.")
-  (supertype-memoize (make-hash-table :test #'equal) :type hash-table
-                     :documentation "Serve memoization for
- `comp-common-supertype'."))
+  (union-typesets-mem (make-hash-table :test #'equal) :type hash-table
+                      :documentation "Serve memoization for
+`comp-union-typesets'."))
 
 (cl-defstruct comp-args-base
   (min nil :type number
@@ -419,14 +431,68 @@ CFG is mutated by a pass.")
   (slot nil :type (or fixnum symbol)
         :documentation "Slot number in the array if a number or
         'scratch' for scratch slot.")
-  (const-vld nil :type boolean
-             :documentation "Valid signal for the following slot.")
-  (constant nil
-            :documentation "When const-vld non-nil this is used for holding
- a value known at compile time.")
-  (type nil :type symbol
-        :documentation "When non-nil indicates the type when known at compile
- time."))
+  (typeset '(t) :type list
+           :documentation "List of possible types the mvar can assume.
+Each element cannot be a subtype of any other element of this slot.")
+  (valset '() :type list
+          :documentation "List of possible values the mvar can assume.
+Interg values are handled in the `range' slot.")
+  (range '() :type list
+         :documentation "Integer interval."))
+
+(defsubst comp-mvar-value-vld-p (mvar)
+  "Return t if one single value can be extracted by the MVAR constrains."
+  (or (= (length (comp-mvar-valset mvar)) 1)
+      (let ((r (comp-mvar-range mvar)))
+        (and (= (length r) 1)
+             (let ((low (caar r))
+                   (high (cdar r)))
+               (and
+                (integerp low)
+                (integerp high)
+                (= low high)))))))
+
+(defsubst comp-mvar-value (mvar)
+  "Return the constant value of MVAR.
+`comp-mvar-value-vld-p' *must* be satisfied before calling
+`comp-mvar-const'."
+  (declare (gv-setter
+            (lambda (val)
+              `(if (integerp ,val)
+                   (setf (comp-mvar-typeset ,mvar) nil
+                         (comp-mvar-range ,mvar) (list (cons ,val ,val)))
+                 (setf (comp-mvar-typeset ,mvar) nil
+                       (comp-mvar-valset ,mvar) (list ,val))))))
+  (let ((v (comp-mvar-valset mvar)))
+    (if (= (length v) 1)
+        (car v)
+      (caar (comp-mvar-range mvar)))))
+
+(defsubst comp-mvar-fixnum-p (mvar)
+  "Return t if MVAR is certainly a fixnum."
+  (when-let (range (comp-mvar-range mvar))
+    (let* ((low (caar range))
+           (high (cdar (last range))))
+      (unless (or (eq low '-)
+                  (< low most-negative-fixnum)
+                  (eq high '+)
+                  (> high most-positive-fixnum))
+        t))))
+
+(defsubst comp-mvar-symbol-p (mvar)
+  "Return t if MVAR is certainly a symbol."
+  (equal (comp-mvar-typeset mvar) '(symbol)))
+
+(defsubst comp-mvar-cons-p (mvar)
+  "Return t if MVAR is certainly a cons."
+  (equal (comp-mvar-typeset mvar) '(cons)))
+
+(defun comp-mvar-type-hint-match-p (mvar type-hint)
+  "Match MVAR against TYPE-HINT.
+In use by the backend."
+  (cl-ecase type-hint
+    (cons (comp-mvar-cons-p mvar))
+    (fixnum (comp-mvar-fixnum-p mvar))))
 
 ;; Special vars used by some passes
 (defvar comp-func)
@@ -463,6 +529,14 @@ To be used by all entry points."
   "Type-hint predicate for function name FUNC."
   (when (memq func comp-type-hints) t))
 
+(defsubst comp-func-ret-typeset (func)
+  "Return the typeset returned by function FUNC. "
+  (or (alist-get func comp-known-ret-types) '(t)))
+
+(defsubst comp-func-ret-range (func)
+  "Return the range returned by function FUNC. "
+  (alist-get func comp-known-ret-ranges))
+
 (defun comp-func-unique-in-cu-p (func)
   "Return t if FUNC is known to be unique in the current compilation unit."
   (if (symbolp func)
@@ -943,10 +1017,14 @@ STACK-OFF is the index of the first slot frame involved."
                              collect (comp-slot-n sp))))
 
 (cl-defun make-comp-mvar (&key slot (constant nil const-vld) type)
-  (when const-vld
-    (comp-add-const-to-relocs constant))
-  (make--comp-mvar :slot slot :const-vld const-vld :constant constant
-                   :type type))
+  "`comp-mvar' intitializer."
+  (let ((mvar (make--comp-mvar :slot slot)))
+    (when const-vld
+      (comp-add-const-to-relocs constant)
+      (setf (comp-mvar-value mvar) constant))
+    (when type
+      (setf (comp-mvar-typeset mvar) (list type)))
+    mvar))
 
 (defun comp-new-frame (size &optional ssa)
   "Return a clean frame of meta variables of size SIZE.
@@ -1823,11 +1901,9 @@ blocks."
 ;; this form is called 'minimal SSA form'.
 ;; This pass should be run every time basic blocks or m-var are shuffled.
 
-(cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
-  (let ((mvar (make--comp-mvar :slot slot
-                               :const-vld const-vld
-                               :constant constant
-                               :type type)))
+(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type)
+  "Same as `make-comp-mvar' but set the `id' slot."
+  (let ((mvar (apply #'make-comp-mvar rest)))
     (setf (comp-mvar-id mvar) (sxhash-eq mvar))
     mvar))
 
@@ -2130,19 +2206,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
 ;; This is also responsible for removing function calls to pure functions if
 ;; possible.
 
-(defsubst comp-strict-type-of (obj)
-  "Given OBJ return its type understanding fixnums."
-  ;; Should be certainly smarter but now we take advantages just from fixnums.
-  (if (fixnump obj)
-      'fixnum
-    (type-of obj)))
+(defconst comp--typeof-types (mapcar (lambda (x)
+                                       (append x '(t)))
+                                     cl--typeof-types)
+  ;; TODO can we just add t in `cl--typeof-types'?
+  "Like `cl--typeof-types' but with t as common supertype.")
 
 (defun comp-supertypes (type)
   "Return a list of pairs (supertype . hierarchy-level) for TYPE."
   (cl-loop
    named outer
    with found = nil
-   for l in cl--typeof-types
+   for l in comp--typeof-types
    do (cl-loop
        for x in l
        for i from (length l) downto 0
@@ -2165,10 +2240,105 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
 
 (defun comp-common-supertype (&rest types)
   "Return the first common supertype of TYPES."
-  (or (gethash types (comp-ctxt-supertype-memoize comp-ctxt))
-      (puthash types
-               (cl-reduce #'comp-common-supertype-2 types)
-               (comp-ctxt-supertype-memoize comp-ctxt))))
+  (cl-reduce #'comp-common-supertype-2 types))
+
+(defsubst comp-subtype-p (type1 type2)
+  "Return t if TYPE1 is a subtype of TYPE1 or nil otherwise."
+  (eq (comp-common-supertype-2 type1 type2) type2))
+
+(defun comp-union-typesets (&rest typesets)
+  "Union types present into TYPESETS."
+  (or (gethash typesets (comp-ctxt-union-typesets-mem comp-ctxt))
+      (puthash typesets
+               (cl-loop
+                with types = (apply #'append typesets)
+                with res = '()
+                for lane in comp--typeof-types
+                do (cl-loop
+                    with last = nil
+                    for x in lane
+                    when (memq x types)
+                      do (setf last x)
+                    finally (when last
+                              (push last res)))
+                finally (cl-return (cl-remove-duplicates res)))
+               (comp-ctxt-union-typesets-mem comp-ctxt))))
+
+(defsubst comp-range-1+ (x)
+  (if (symbolp x)
+      x
+    (1+ x)))
+
+(defsubst comp-range-1- (x)
+  (if (symbolp x)
+      x
+    (1- x)))
+
+(defsubst comp-range-< (x y)
+  (cond
+   ((eq x '+) nil)
+   ((eq x '-) t)
+   ((eq y '+) t)
+   ((eq y '-) nil)
+   (t (< x y))))
+
+(defun comp-range-union (&rest ranges)
+  "Combine integer intervals RANGES by union operation."
+  (cl-loop
+   with all-ranges = (apply #'append ranges)
+   with lows = (mapcar (lambda (x)
+                         (cons (comp-range-1- (car x)) 'l))
+                       all-ranges)
+   with highs = (mapcar (lambda (x)
+                          (cons (cdr x) 'h))
+                        all-ranges)
+   with nest = 0
+   with low = nil
+   with res = ()
+   for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+   if (eq x 'l)
+   do
+   (when (zerop nest)
+     (setf low i))
+   (cl-incf nest)
+   else
+   do
+   (when (= nest 1)
+     (push `(,(comp-range-1+ low) . ,i) res))
+   (cl-decf nest)
+   finally (cl-return (reverse res))))
+
+(defun comp-range-intersection (&rest ranges)
+  "Combine integer intervals RANGES by intersecting."
+  (cl-loop
+   with all-ranges = (apply #'append ranges)
+   with n-ranges = (length ranges)
+   with lows = (mapcar (lambda (x)
+                         (cons (car x) 'l))
+                       all-ranges)
+   with highs = (mapcar (lambda (x)
+                          (cons (cdr x) 'h))
+                        all-ranges)
+   with nest = 0
+   with low = nil
+   with res = ()
+   initially (when (cl-some #'null ranges)
+               ;; Intersecting with a null range always results in a
+               ;; null range.
+               (cl-return '()))
+   for (i . x) in (cl-sort (nconc lows highs) #'comp-range-< :key #'car)
+   if (eq x 'l)
+   do
+   (cl-incf nest)
+   (when (= nest n-ranges)
+     (setf low i))
+   else
+   do
+   (when (= nest n-ranges)
+     (push `(,low . ,i)
+           res))
+   (cl-decf nest)
+   finally (cl-return (reverse res))))
 
 (defun comp-copy-insn (insn)
   "Deep copy INSN."
@@ -2213,20 +2383,18 @@ Forward propagate immediate involed in assignments."
        for insn in (comp-block-insns b)
        do (pcase insn
             (`(setimm ,lval ,v)
-             (setf (comp-mvar-const-vld lval) t
-                   (comp-mvar-constant lval) v
-                   (comp-mvar-type lval) (comp-strict-type-of v)))))))
+             (setf (comp-mvar-value lval) v))))))
 
 (defsubst comp-mvar-propagate (lval rval)
   "Propagate into LVAL properties of RVAL."
-  (setf (comp-mvar-const-vld lval) (comp-mvar-const-vld rval)
-        (comp-mvar-constant lval) (comp-mvar-constant rval)
-        (comp-mvar-type lval) (comp-mvar-type rval)))
+  (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval)
+        (comp-mvar-valset lval) (comp-mvar-valset rval)
+        (comp-mvar-range lval) (comp-mvar-range rval)))
 
 (defsubst comp-function-foldable-p (f args)
   "Given function F called with ARGS return non-nil when optimizable."
-  (and (cl-every #'comp-mvar-const-vld args)
-       (comp-function-pure-p f)))
+  (and (comp-function-pure-p f)
+       (cl-every #'comp-mvar-value-vld-p args)))
 
 (defsubst comp-function-call-maybe-fold (insn f args)
   "Given INSN when F is pure if all ARGS are known remove the function call."
@@ -2238,10 +2406,10 @@ Forward propagate immediate involed in assignments."
     (cond
      ((eq f 'symbol-value)
       (when-let* ((arg0 (car args))
-                  (const (comp-mvar-const-vld arg0))
-                  (ok-to-optim (member (comp-mvar-constant arg0)
+                  (const (comp-mvar-value-vld-p arg0))
+                  (ok-to-optim (member (comp-mvar-value arg0)
                                        comp-symbol-values-optimizable)))
-        (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-constant
+        (rewrite-insn-as-setimm insn (symbol-value (comp-mvar-value
                                                     (car args))))))
      ((comp-function-foldable-p f args)
       (ignore-errors
@@ -2254,7 +2422,7 @@ Forward propagate immediate involed in assignments."
                       ;; and know to be pure.
                       (comp-func-byte-func f-in-ctxt)
                     f))
-               (value (comp-apply-in-env f (mapcar #'comp-mvar-constant args))))
+               (value (comp-apply-in-env f (mapcar #'comp-mvar-value args))))
           (rewrite-insn-as-setimm insn value)))))))
 
 (defun comp-fwprop-insn (insn)
@@ -2263,13 +2431,19 @@ Forward propagate immediate involed in assignments."
     (`(set ,lval ,rval)
      (pcase rval
        (`(,(or 'call 'callref) ,f . ,args)
-        (setf (comp-mvar-type lval)
-              (alist-get f comp-known-ret-types))
+        (if-let ((range (comp-func-ret-range f)))
+            (setf (comp-mvar-range lval) (list range)
+                  (comp-mvar-typeset lval) nil)
+          (setf (comp-mvar-typeset lval)
+                (comp-func-ret-typeset f)))
         (comp-function-call-maybe-fold insn f args))
        (`(,(or 'direct-call 'direct-callref) ,f . ,args)
         (let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
-          (setf (comp-mvar-type lval)
-                (alist-get f comp-known-ret-types))
+          (if-let ((range (comp-func-ret-range f)))
+              (setf (comp-mvar-range lval) (list range)
+                    (comp-mvar-typeset lval) nil)
+            (setf (comp-mvar-typeset lval)
+                  (comp-func-ret-typeset f)))
           (comp-function-call-maybe-fold insn f args)))
        (_
         (comp-mvar-propagate lval rval))))
@@ -2278,31 +2452,46 @@ Forward propagate immediate involed in assignments."
        ('eq
         (comp-mvar-propagate lval rval))
        ((or 'eql 'equal)
-        (if (memq (comp-mvar-type rval) '(symbol fixnum))
+        (if (or (comp-mvar-symbol-p rval)
+                (comp-mvar-fixnum-p rval))
             (comp-mvar-propagate lval rval)
-          (setf (comp-mvar-type lval) (comp-mvar-type rval))))
+          (setf (comp-mvar-typeset lval) (comp-mvar-typeset rval))))
        ('=
-        (if (eq (comp-mvar-type rval) 'fixnum)
+        (if (comp-mvar-fixnum-p rval)
             (comp-mvar-propagate lval rval)
-          (setf (comp-mvar-type lval) 'number)))))
+          (setf (comp-mvar-typeset lval)
+                (unless (comp-mvar-range rval)
+                  '(number)))))))
     (`(setimm ,lval ,v)
-     (setf (comp-mvar-const-vld lval) t
-           (comp-mvar-constant lval) v
-           (comp-mvar-type lval) (comp-strict-type-of v)))
+     (setf (comp-mvar-value lval) v))
     (`(phi ,lval . ,rest)
-     (let ((rvals (mapcar #'car rest)))
-       ;; Forward const prop here.
-       (when-let* ((vld (cl-every #'comp-mvar-const-vld rvals))
-                   (consts (mapcar #'comp-mvar-constant rvals))
-                   (x (car consts))
-                   (equals (cl-every (lambda (y) (equal x y)) consts)))
-         (setf (comp-mvar-const-vld lval) t
-               (comp-mvar-constant lval) x))
-       ;; Forward type propagation.
-       (when-let* ((types (mapcar #'comp-mvar-type rvals))
-                   (non-empty (cl-notany #'null types))
-                   (x (comp-common-supertype types)))
-         (setf (comp-mvar-type lval) x))))))
+     (let* ((rvals (mapcar #'car rest))
+            (values (mapcar #'comp-mvar-valset rvals))
+            (from-latch (cl-some
+                         (lambda (x)
+                           (comp-latch-p
+                            (gethash (cdr x)
+                                     (comp-func-blocks comp-func))))
+                         rest)))
+
+       ;; Type propagation.
+       (setf (comp-mvar-typeset lval)
+             (apply #'comp-union-typesets (mapcar #'comp-mvar-typeset rvals)))
+       ;; Value propagation.
+       (setf (comp-mvar-valset lval)
+             (when (cl-every #'consp values)
+               ;; TODO memoize?
+               (cl-remove-duplicates (apply #'append values)
+                                     :test #'equal)))
+       ;; Range propagation
+       (setf (comp-mvar-range lval)
+             (when (and (not from-latch)
+                        (cl-notany (lambda (x)
+                                     (comp-subtype-p 'integer x))
+                                   (comp-mvar-typeset lval)))
+               ;; TODO memoize?
+               (apply #'comp-range-union
+                      (mapcar #'comp-mvar-range rvals))))))))
 
 (defun comp-fwprop* ()
   "Propagate for set* and phi operands.
@@ -2416,11 +2605,11 @@ FUNCTION can be a function-name or byte compiled function."
         (pcase insn
           (`(set ,lval (callref funcall ,f . ,rest))
            (when-let ((new-form (comp-call-optim-form-call
-                                 (comp-mvar-constant f) rest)))
+                                 (comp-mvar-value f) rest)))
              (setf insn `(set ,lval ,new-form))))
           (`(callref funcall ,f . ,rest)
            (when-let ((new-form (comp-call-optim-form-call
-                                 (comp-mvar-constant f) rest)))
+                                 (comp-mvar-value f) rest)))
              (setf insn new-form)))))))
 
 (defun comp-call-optim (_)
@@ -2639,7 +2828,8 @@ Update all insn accordingly."
              do
              (cl-assert (null (gethash idx reverse-h)))
              (cl-assert (fixnump idx))
-             (setf (comp-mvar-constant mvar) idx)
+             (setf (comp-mvar-valset mvar) ()
+                   (comp-mvar-range mvar) (list (cons idx idx)))
              (puthash idx t reverse-h))))
 
 (defun comp-compile-ctxt-to-file (name)

diff --git a/src/comp.c b/src/comp.c
index cb5f1a1ce965cfefcc0226febfde80acbdf001c1..0d464281858d7c6a53a0b6ba1df7190fbf9bfed1 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -1845,32 +1845,32 @@ emit_PURE_P (gcc_jit_rvalue *ptr)
 static gcc_jit_rvalue *
 emit_mvar_rval (Lisp_Object mvar)
 {
-  Lisp_Object const_vld = CALL1I (comp-mvar-const-vld, mvar);
-  Lisp_Object constant = CALL1I (comp-mvar-constant, mvar);
+  Lisp_Object const_vld = CALL1I (comp-mvar-value-vld-p, mvar);
 
   if (!NILP (const_vld))
     {
+      Lisp_Object value = CALL1I (comp-mvar-value, mvar);
       if (comp.debug > 1)
        {
          Lisp_Object func =
-           Fgethash (constant,
+           Fgethash (value,
                      CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt),
                      Qnil);
 
          emit_comment (
            SSDATA (
              Fprin1_to_string (
-               NILP (func) ? constant : CALL1I (comp-func-c-name, func),
+               NILP (func) ? value : CALL1I (comp-func-c-name, func),
                Qnil)));
        }
-      if (FIXNUMP (constant))
+      if (FIXNUMP (value))
        {
          /* We can still emit directly objects that are self-contained in a
             word (read fixnums).  */
-          return emit_rvalue_from_lisp_obj (constant);
+          return emit_rvalue_from_lisp_obj (value);
        }
       /* Other const objects are fetched from the reloc array.  */
-      return emit_lisp_obj_rval (constant);
+      return emit_lisp_obj_rval (value);
     }
 
   return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar));
@@ -2371,12 +2371,13 @@ static gcc_jit_rvalue *
 emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
                          Lisp_Object type)
 {
-  bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type);
+  bool hint_match =
+    !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
   gcc_jit_rvalue *args[] =
     { emit_mvar_rval (SECOND (insn)),
       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
                                           comp.bool_type,
-                                          type_hint) };
+                                          hint_match) };
 
   return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args);
 }
@@ -2386,13 +2387,14 @@ static gcc_jit_rvalue *
 emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
                           Lisp_Object type)
 {
-  bool type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type);
+  bool hint_match =
+    !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
   gcc_jit_rvalue *args[] =
     { emit_mvar_rval (SECOND (insn)),
       emit_mvar_rval (THIRD (insn)),
       gcc_jit_context_new_rvalue_from_int (comp.ctxt,
                                           comp.bool_type,
-                                          type_hint) };
+                                          hint_match) };
 
   return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args);
 }

diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 21c8abad038597410f73f2e3e042594a755a8f01..48687d92021c1ac1845ed29b1ce80b11da9e0646 100644 (file)
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -37,7 +37,7 @@
 (defconst comp-test-dyn-src
   (concat comp-test-directory "comp-test-funcs-dyn.el"))
 
-(when (boundp 'comp-ctxt)
+(when (featurep 'nativecomp)
   (message "Compiling tests...")
   (load (native-compile comp-test-src))
   (load (native-compile comp-test-dyn-src)))
@@ -676,8 +676,8 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html."
   (cl-loop for y in insn
            when (cond
                  ((consp y) (comp-tests-mentioned-p x y))
-                 ((and (comp-mvar-p y) (comp-mvar-const-vld y))
-                  (equal (comp-mvar-constant y) x))
+                 ((and (comp-mvar-p y) (comp-mvar-value-vld-p y))
+                  (equal (comp-mvar-value y) x))
                  (t (equal x y)))
              return t))
 
@@ -804,8 +804,8 @@ Return a list of results."
      (lambda (insn)
        (pcase insn
          (`(return ,mvar)
-          (and (comp-mvar-const-vld mvar)
-               (= (comp-mvar-constant mvar) 123)))))))))
+          (and (comp-mvar-value-vld-p mvar)
+               (eql (comp-mvar-value mvar) 123)))))))))
 
 (defvar comp-tests-cond-rw-expected-type nil
   "Type to expect in `comp-tests-cond-rw-checker-type'.")
@@ -819,7 +819,8 @@ Return a list of results."
      (lambda (insn)
        (pcase insn
          (`(return ,mvar)
-          (eq (comp-mvar-type mvar) comp-tests-cond-rw-expected-type))))))))
+          (equal (comp-mvar-typeset mvar)
+                 comp-tests-cond-rw-expected-type))))))))
 
 (defvar comp-tests-cond-rw-0-var)
 (comp-deftest cond-rw-0 ()
@@ -839,40 +840,39 @@ Return a list of results."
 (comp-deftest cond-rw-1 ()
   "Test cond-rw pass allow us to propagate type+val under `eq' tests."
   (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type 'fixnum)
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)
-                                (comp-final comp-tests-cond-rw-checker-val))))
+        (comp-tests-cond-rw-expected-type '(integer))
+        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
+                                            comp-tests-cond-rw-checker-val))))
     (subr-native-elisp-p (native-compile '(lambda (x) (if (eq x 123) x t))))
     (subr-native-elisp-p (native-compile '(lambda (x) (if (eq 123 x) x t))))))
 
 (comp-deftest cond-rw-2 ()
   "Test cond-rw pass allow us to propagate type+val under `=' tests."
   (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type 'fixnum)
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)
-                                (comp-final comp-tests-cond-rw-checker-val))))
+        (comp-tests-cond-rw-expected-type '(integer))
+        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
+                                            comp-tests-cond-rw-checker-val))))
     (subr-native-elisp-p (native-compile '(lambda (x) (if (= x 123) x t))))))
 
 (comp-deftest cond-rw-3 ()
   "Test cond-rw pass allow us to propagate type+val under `eql' tests."
   (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type 'fixnum)
-        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type)
-                                (comp-final comp-tests-cond-rw-checker-val))))
+        (comp-tests-cond-rw-expected-type '(integer))
+        (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type
+                                            comp-tests-cond-rw-checker-val))))
     (subr-native-elisp-p (native-compile '(lambda (x) (if (eql 123 x) x t))))))
 
 (comp-deftest cond-rw-4 ()
   "Test cond-rw pass allow us to propagate type under `=' tests."
   (let ((lexical-binding t)
-        (comp-tests-cond-rw-expected-type 'number)
+        (comp-tests-cond-rw-expected-type '(number))
         (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type))))
     (subr-native-elisp-p (native-compile '(lambda (x y) (if (= x y) x t))))))
 
 (comp-deftest cond-rw-5 ()
   "Test cond-rw pass allow us to propagate type under `=' tests."
-  (let ((lexical-binding t)
-        (comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f)
-        (comp-tests-cond-rw-expected-type 'fixnum)
+  (let ((comp-tests-cond-rw-checked-function #'comp-tests-cond-rw-4-f)
+        (comp-tests-cond-rw-expected-type '(integer))
         (comp-post-pass-hooks '((comp-final comp-tests-cond-rw-checker-type))))
     (eval '(defun comp-tests-cond-rw-4-f (x y)
              (declare (speed 3))
@@ -883,4 +883,48 @@ Return a list of results."
     (native-compile #'comp-tests-cond-rw-4-f)
     (should (subr-native-elisp-p (symbol-function #'comp-tests-cond-rw-4-f)))))
 
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Range propagation tests. ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(comp-deftest range-simple-union ()
+  (should (equal (comp-range-union '((-1 . 0)) '((3 . 4)))
+                 '((-1 . 0) (3 . 4))))
+  (should (equal (comp-range-union '((-1 . 2)) '((3 . 4)))
+                 '((-1 . 4))))
+  (should (equal (comp-range-union '((-1 . 3)) '((3 . 4)))
+                 '((-1 . 4))))
+  (should (equal (comp-range-union '((-1 . 4)) '((3 . 4)))
+                 '((-1 . 4))))
+  (should (equal (comp-range-union '((-1 . 5)) '((3 . 4)))
+                 '((-1 . 5))))
+  (should (equal (comp-range-union '((-1 . 0)) '())
+                 '((-1 . 0)))))
+
+(comp-deftest range-simple-intersection ()
+  (should (equal (comp-range-intersection '((-1 . 0)) '((3 . 4)))
+                 '()))
+  (should (equal (comp-range-intersection '((-1 . 2)) '((3 . 4)))
+                 '()))
+  (should (equal (comp-range-intersection '((-1 . 3)) '((3 . 4)))
+                 '((3 . 3))))
+  (should (equal (comp-range-intersection '((-1 . 4)) '((3 . 4)))
+                 '((3 . 4))))
+  (should (equal (comp-range-intersection '((-1 . 5)) '((3 . 4)))
+                 '((3 . 4))))
+  (should (equal (comp-range-intersection '((-1 . 0)) '())
+                 '())))
+
+(comp-deftest union-types ()
+  (let ((comp-ctxt (make-comp-ctxt)))
+    (should (equal (comp-union-typesets '(integer) '(number))
+                   '(number)))
+    (should (equal (comp-union-typesets '(integer symbol) '(number))
+                   '(symbol number)))
+    (should (equal (comp-union-typesets '(integer symbol) '(number list))
+                   '(list symbol number)))
+    (should (equal (comp-union-typesets '(integer symbol) '())
+                   '(symbol integer)))))
+
 ;;; comp-tests.el ends here