[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/native-comp e96cd4e 2/8: Add initial nativecomp typeset and rang
From: |
Andrea Corallo |
Subject: |
feature/native-comp e96cd4e 2/8: Add initial nativecomp typeset and range propagation support |
Date: |
Wed, 11 Nov 2020 19:03:06 -0500 (EST) |
branch: feature/native-comp
commit e96cd4e82c9aca01f136ccdd7a3b0fbf2db01e50
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>
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.
---
lisp/emacs-lisp/cl-preloaded.el | 3 +-
lisp/emacs-lisp/comp.el | 350 +++++++++++++++++++++++++++++++---------
src/comp.c | 24 +--
test/src/comp-tests.el | 82 +++++++---
4 files changed, 347 insertions(+), 112 deletions(-)
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index b5dbcbd..eed43c5 100644
--- 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 8bee8af..ad0ac21 100644
--- 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 cb5f1a1..0d46428 100644
--- 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 21c8aba..48687d9 100644
--- 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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
- feature/native-comp updated (e20cdf9 -> 2435c10), Andrea Corallo, 2020/11/11
- feature/native-comp e96cd4e 2/8: Add initial nativecomp typeset and range propagation support,
Andrea Corallo <=
- feature/native-comp 00b4e0a 4/8: * Fix limple-mode for new type and range limple semantic, Andrea Corallo, 2020/11/11
- feature/native-comp c3d0e2a 1/8: * Rename two nativecomp functions, Andrea Corallo, 2020/11/11
- feature/native-comp a214882 5/8: * Add to elisp-mode `emacs-lisp-native-compile-and-load', Andrea Corallo, 2020/11/11
- feature/native-comp 6b7c257 6/8: * Unline some functions to optimize bootstrap time, Andrea Corallo, 2020/11/11
- feature/native-comp 2435c10 8/8: * Nativecomp testsuite rework for derived return type specifiers, Andrea Corallo, 2020/11/11
- feature/native-comp 175efec 3/8: Add a nativecomp testcase, Andrea Corallo, 2020/11/11
- feature/native-comp 93a80a4 7/8: * Add nativecomp derived return type specifier computation support, Andrea Corallo, 2020/11/11