procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix native comp prediction on null functionp tested objects

Browse source 
* lisp/emacs-lisp/comp.el (comp-known-predicates)
(comp-known-predicates-h): Update.
(comp--pred-to-pos-cstr, comp--pred-to-neg-cstr): New functions.
(comp--add-cond-cstrs): Make use of them.

* test/src/comp-tests.el (comp-tests-type-spec-tests): Add a test.
This commit is contained in:
Andrea Corallo 2024-03-26 11:14:08 +01:00
parent b7b9a0a5c1
commit 8cc67dbcec
2 changed files with 64 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

101
lisp/emacs-lisp/comp.el
View file

@ -193,49 +193,52 @@ Useful to hook into pass checkers.")
;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the ;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the
;; relation type <-> predicate is not bijective (bug#45576). ;; relation type <-> predicate is not bijective (bug#45576).
(defconst comp-known-predicates (defconst comp-known-predicates
'((arrayp . array) '((arrayp array)
(atom . atom) (atom atom)
(bool-vector-p . bool-vector) (bool-vector-p bool-vector)
(booleanp . boolean) (booleanp boolean)
(bufferp . buffer) (bufferp buffer)
(char-table-p . char-table) (char-table-p char-table)
(characterp . fixnum) (characterp fixnum)
(consp . cons) (consp cons)
(floatp . float) (floatp float)
(framep . frame) (framep frame)
(functionp . (or function symbol cons)) (functionp (or function symbol cons) (not function))
(hash-table-p . hash-table) (hash-table-p hash-table)
(integer-or-marker-p . integer-or-marker) (integer-or-marker-p integer-or-marker)
(integerp . integer) (integerp integer)
(keywordp . keyword) (keywordp keyword)
(listp . list) (listp list)
(markerp . marker) (markerp marker)
(natnump . (integer 0 *)) (natnump (integer 0 *))
(null . null) (null null)
(number-or-marker-p . number-or-marker) (number-or-marker-p number-or-marker)
(numberp . number) (numberp number)
(numberp . number) (numberp number)
(obarrayp . obarray) (obarrayp obarray)
(overlayp . overlay) (overlayp overlay)
(processp . process) (processp process)
(sequencep . sequence) (sequencep sequence)
(stringp . string) (stringp string)
(subrp . subr) (subrp subr)
(symbol-with-pos-p . symbol-with-pos) (symbol-with-pos-p symbol-with-pos)
(symbolp . symbol) (symbolp symbol)
(vectorp . vector) (vectorp vector)
(windowp . window)) (windowp window))
"Alist predicate -> matched type specifier.") "(PREDICATE TYPE-IF-SATISFIED ?TYPE-IF-NOT-SATISFIED).")
(defconst comp-known-predicates-h (defconst comp-known-predicates-h
(cl-loop (cl-loop
with comp-ctxt = (make-comp-cstr-ctxt) with comp-ctxt = (make-comp-cstr-ctxt)
with h = (make-hash-table :test #'eq) with h = (make-hash-table :test #'eq)
for (pred . type-spec) in comp-known-predicates for (pred . type-specs) in comp-known-predicates
for cstr = (comp-type-spec-to-cstr type-spec) for pos-cstr = (comp-type-spec-to-cstr (car type-specs))
do (puthash pred cstr h) for neg-cstr = (if (length> type-specs 1)
(comp-type-spec-to-cstr (cl-second type-specs))
(comp-cstr-negation-make pos-cstr))
do (puthash pred (cons pos-cstr neg-cstr) h)
finally return h) finally return h)
"Hash table function -> `comp-constraint'.") "Hash table FUNCTION -> (POS-CSTR . NEG-CSTR).")
(defun comp--known-predicate-p (predicate) (defun comp--known-predicate-p (predicate)
"Return t if PREDICATE is known." "Return t if PREDICATE is known."
@ -243,10 +246,14 @@ Useful to hook into pass checkers.")
(gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))
t)) t))
(defun comp--pred-to-cstr (predicate) (defun comp--pred-to-pos-cstr (predicate)
"Given PREDICATE, return the corresponding constraint." "Given PREDICATE, return the corresponding positive constraint."
;; FIXME: Unify those two hash tables? (or (car-safe (gethash predicate comp-known-predicates-h))
(or (gethash predicate comp-known-predicates-h) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
(defun comp--pred-to-neg-cstr (predicate)
"Given PREDICATE, return the corresponding negative constraint."
(or (cdr-safe (gethash predicate comp-known-predicates-h))
(gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt)))) (gethash predicate (comp-cstr-ctxt-pred-type-h comp-ctxt))))
(defconst comp-symbol-values-optimizable '(most-positive-fixnum (defconst comp-symbol-values-optimizable '(most-positive-fixnum
@ -2033,7 +2040,6 @@ TARGET-BB-SYM is the symbol name of the target block."
(cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks)) (cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
(cl-loop (cl-loop
with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b) with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
with cstr = (comp--pred-to-cstr fun)
for branch-target-cell on blocks for branch-target-cell on blocks
for branch-target = (car branch-target-cell) for branch-target = (car branch-target-cell)
for negated in '(t nil) for negated in '(t nil)
@ -2041,7 +2047,10 @@ TARGET-BB-SYM is the symbol name of the target block."
do do
(let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target)) (setf (car branch-target-cell) (comp-block-name block-target))
(comp--emit-assume 'and target-mvar cstr block-target negated)) (comp--emit-assume 'and target-mvar (if negated
(comp--pred-to-neg-cstr fun)
(comp--pred-to-pos-cstr fun))
block-target nil))
finally (cl-return-from in-the-basic-block))) finally (cl-return-from in-the-basic-block)))
;; Match predicate on the negated branch (unless). ;; Match predicate on the negated branch (unless).
(`((set ,(and (pred comp-mvar-p) cmp-res) (`((set ,(and (pred comp-mvar-p) cmp-res)
@ -2052,7 +2061,6 @@ TARGET-BB-SYM is the symbol name of the target block."
(cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks)) (cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
(cl-loop (cl-loop
with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b) with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
with cstr = (comp--pred-to-cstr fun)
for branch-target-cell on blocks for branch-target-cell on blocks
for branch-target = (car branch-target-cell) for branch-target = (car branch-target-cell)
for negated in '(nil t) for negated in '(nil t)
@ -2060,7 +2068,10 @@ TARGET-BB-SYM is the symbol name of the target block."
do do
(let ((block-target (comp--add-cond-cstrs-target-block b branch-target))) (let ((block-target (comp--add-cond-cstrs-target-block b branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target)) (setf (car branch-target-cell) (comp-block-name block-target))
(comp--emit-assume 'and target-mvar cstr block-target negated)) (comp--emit-assume 'and target-mvar (if negated
(comp--pred-to-neg-cstr fun)
(comp--pred-to-pos-cstr fun))
block-target nil))
finally (cl-return-from in-the-basic-block)))) finally (cl-return-from in-the-basic-block))))
(setf prev-insns-seq insns-seq)))) (setf prev-insns-seq insns-seq))))

9
test/src/comp-tests.el
View file

@ -1496,7 +1496,14 @@ Return a list of results."
(if (comp-foo-p x) (if (comp-foo-p x)
x x
(error ""))) (error "")))
'comp-foo))) 'comp-foo)
;; 80
((defun comp-tests-ret-type-spec-f (x)
(if (functionp x)
(error "")
x))
'(not function))))
(defun comp-tests-define-type-spec-test (number x) (defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()