From 459d99c027db1a630174e3269d49188832e57dca Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sun, 29 Sep 2024 17:32:08 +0300 Subject: Propagate (integerp (- x)), x => integer. --- src/compiler/constraint-back.lisp | 89 ++++++++++++++++++++++++--------------- tests/constraint.pure.lisp | 12 +++++- 2 files changed, 67 insertions(+), 34 deletions(-) diff --git a/src/compiler/constraint-back.lisp b/src/compiler/constraint-back.lisp index c96be4ab9..7396fafcb 100644 --- a/src/compiler/constraint-back.lisp +++ b/src/compiler/constraint-back.lisp @@ -17,46 +17,63 @@ :exit-if-null)) (funcall propagate node nth-value kind constraint gen consequent alternative))))) -(defun numeric-contagion-constraint-back (x y gen constraint consequent &optional complex-p) +(defun numeric-contagion-constraint-back (x y gen constraint consequent &optional complex-p + (x-type (lvar-type x)) + (y-type (lvar-type y))) (flet ((add (lvar type) - (let ((var (ok-lvar-lambda-var lvar gen))) + (let ((var (and lvar + (ok-lvar-lambda-var lvar gen)))) (when var (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) (let ((real-type (if complex-p ;; complex rationals multiplied by 0 will produce an integer 0. (specifier-type '(and real (not (eql 0)))) (specifier-type 'real)))) (cond ((csubtypep constraint (specifier-type 'rational)) - (cond ((or (csubtypep (lvar-type x) real-type) - (csubtypep (lvar-type y) real-type)) + (cond ((or (csubtypep x-type real-type) + (csubtypep y-type real-type)) (add x (specifier-type 'rational)) (add y (specifier-type 'rational))) (t (add x (specifier-type '(or rational (complex rational)))) (add y (specifier-type '(or rational (complex rational))))))) ((and (csubtypep constraint (specifier-type 'double-float)) - (let ((x-double (types-equal-or-intersect (lvar-type x) (specifier-type 'double-float))) - (y-double (types-equal-or-intersect (lvar-type y) (specifier-type 'double-float)))) - (or (when (and x-double - (not y-double) - (not (csubtypep (lvar-type x) (specifier-type 'double-float)))) - (add x (specifier-type 'double-float)) - t) - (when (and y-double - (not x-double) - (not (csubtypep (lvar-type y) (specifier-type 'double-float)))) - (add x (specifier-type 'double-float)) - t))))) + (cond ((not x) + (add y (specifier-type 'double-float)) + t) + (t + (let ((x-double (types-equal-or-intersect x-type (specifier-type 'double-float))) + (y-double (types-equal-or-intersect y-type (specifier-type 'double-float)))) + (or (when (and x-double + (not y-double) + (not (csubtypep x-type (specifier-type 'double-float)))) + (add x (specifier-type 'double-float)) + t) + (when (and y-double + (not x-double) + (not (csubtypep y-type (specifier-type 'double-float)))) + (add x (specifier-type 'double-float)) + t))))))) ((and (csubtypep constraint (specifier-type 'single-float)) - (let ((x-double (types-equal-or-intersect (lvar-type x) (specifier-type 'double-float))) - (y-double (types-equal-or-intersect (lvar-type y) (specifier-type 'double-float)))) - (when x-double - (add x (specifier-type '(not double-float)))) - (when y-double - (add y (specifier-type '(not double-float)))) - nil))) + (cond ((not x) + (add y (specifier-type 'single-float)) + t) + (t + (let ((x-double (types-equal-or-intersect x-type (specifier-type 'double-float))) + (y-double (types-equal-or-intersect y-type (specifier-type 'double-float)))) + (when x-double + (add x (specifier-type '(not double-float)))) + (when y-double + (add y (specifier-type '(not double-float)))) + nil))))) + ((and (not x) + (csubtypep constraint (specifier-type 'float))) + (add y (specifier-type 'float))) + ((and (not x) + (csubtypep constraint (specifier-type 'complex))) + (add y (specifier-type 'complex))) ((csubtypep constraint (specifier-type 'real)) - (let ((x-realp (csubtypep (lvar-type x) (specifier-type 'real))) - (y-realp (csubtypep (lvar-type y) (specifier-type 'real)))) + (let ((x-realp (csubtypep x-type (specifier-type 'real))) + (y-realp (csubtypep y-type (specifier-type 'real)))) (cond ((and x-realp (not y-realp)) (add y (specifier-type 'real))) @@ -93,17 +110,17 @@ (t (numeric-contagion-constraint-back x y gen constraint consequent))))))) -(defoptimizer (- constraint-propagate-back) ((x y) node nth-value kind constraint gen consequent alternative) - (declare (ignore nth-value alternative)) +(defun -constraint-propagate-back (x y x-type y-type kind constraint gen consequent) (case kind (typep (flet ((add (lvar type) - (let ((var (ok-lvar-lambda-var lvar gen))) + (let ((var (and lvar + (ok-lvar-lambda-var lvar gen)))) (when var (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) (cond ((and (csubtypep constraint (specifier-type 'integer)) - (let ((x-integerp (csubtypep (lvar-type x) (specifier-type 'integer))) - (y-integerp (csubtypep (lvar-type y) (specifier-type 'integer)))) + (let ((x-integerp (csubtypep x-type (specifier-type 'integer))) + (y-integerp (csubtypep y-type (specifier-type 'integer)))) (when (or y-integerp x-integerp) (let ((c-interval (type-approximate-interval constraint t))) (let* ((y-interval (type-approximate-interval (lvar-type y) t)) @@ -114,7 +131,7 @@ `(integer ,(or (interval-low int) '*) ,(or (interval-high int) '*)) 'integer)))) - (let* ((x-interval (type-approximate-interval (lvar-type x) t)) + (let* ((x-interval (type-approximate-interval x-type t)) (int (and c-interval x-interval (interval-sub x-interval c-interval)))) @@ -124,7 +141,11 @@ 'integer))))) t)))) (t - (numeric-contagion-constraint-back x y gen constraint consequent))))))) + (numeric-contagion-constraint-back x y gen constraint consequent nil x-type y-type))))))) + +(defoptimizer (- constraint-propagate-back) ((x y) node nth-value kind constraint gen consequent alternative) + (declare (ignore nth-value alternative)) + (-constraint-propagate-back x y (lvar-type x) (lvar-type y) kind constraint gen consequent)) (defoptimizer (* constraint-propagate-back) ((x y) node nth-value kind constraint gen consequent alternative) (declare (ignore nth-value alternative)) @@ -219,7 +240,9 @@ (let ((var (ok-lvar-lambda-var x gen))) (when var (conset-add-constraint-to-eql gen 'typep var (specifier-type `(rational (,(- (interval-high range))))) - nil consequent))))))))) + nil consequent))))))) + (typep + (-constraint-propagate-back nil x (specifier-type '(eql 0)) (lvar-type x) kind constraint gen consequent)))) (defoptimizer (char-code constraint-propagate-back) ((x) node nth-value kind constraint gen consequent alternative) (declare (ignore nth-value)) diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp index ceec0c5a0..350f09d7a 100644 --- a/tests/constraint.pure.lisp +++ b/tests/constraint.pure.lisp @@ -983,7 +983,17 @@ (lambda (x) (when (> (- 3 x) 10) x)) - (or real null))) + (or real null)) + (assert-type + (lambda (x) + (when (floatp (- x)) + x)) + (or float null)) + (assert-type + (lambda (x) + (when (typep (- x) '(integer 1 2)) + x)) + (or (integer -2 -1) null))) (with-test (:name :*back) (assert-type -- cgit v1.2.3-70-g09d2