From e96cd4e82c9aca01f136ccdd7a3b0fbf2db01e50 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 7 Nov 2020 21:47:30 +0100 Subject: 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. --- test/src/comp-tests.el | 82 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 63 insertions(+), 19 deletions(-) (limited to 'test/src') 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 -- cgit v1.2.1