From e96cd4e82c9aca01f136ccdd7a3b0fbf2db01e50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 21:47:30 +0100 Subject: [PATCH] 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 b5dbcbda473..eed43c5ed38 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 8bee8afeacf..ad0ac21389e 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 cb5f1a1ce96..0d464281858 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 21c8abad038..48687d92021 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 -- 2.39.5