From 52b4b92f35a2ece639641ab5cea5e178e1ecf8e6 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sun, 29 Sep 2024 17:17:30 +0300 Subject: Simplify arithmetic constraints. Share the common parts. --- src/compiler/constraint-back.lisp | 216 +++++++++++++++++++++----------------- tests/constraint.pure.lisp | 4 +- 2 files changed, 121 insertions(+), 99 deletions(-) diff --git a/src/compiler/constraint-back.lisp b/src/compiler/constraint-back.lisp index 1834b0aaf..c96be4ab9 100644 --- a/src/compiler/constraint-back.lisp +++ b/src/compiler/constraint-back.lisp @@ -17,6 +17,53 @@ :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) + (flet ((add (lvar type) + (let ((var (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)) + (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))))) + ((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))) + ((csubtypep constraint (specifier-type 'real)) + (let ((x-realp (csubtypep (lvar-type x) (specifier-type 'real))) + (y-realp (csubtypep (lvar-type y) (specifier-type 'real)))) + (cond ((and x-realp + (not y-realp)) + (add y (specifier-type 'real))) + ((and y-realp + (not x-realp)) + (add x (specifier-type 'real)))))))))) + (defoptimizer (+ constraint-propagate-back) ((x y) node nth-value kind constraint gen consequent alternative) (declare (ignore nth-value alternative)) (case kind @@ -27,34 +74,24 @@ (let ((var (ok-lvar-lambda-var lvar gen))) (when var (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) - (cond ((csubtypep constraint (specifier-type 'integer)) - (let ((x-integerp (csubtypep (lvar-type x) (specifier-type 'integer))) - (y-integerp (csubtypep (lvar-type y) (specifier-type 'integer)))) - (flet ((int (c-interval x y) - (let* ((y-interval (type-approximate-interval (lvar-type y) t)) - (int (and c-interval y-interval - (interval-sub c-interval y-interval)))) - (add x (specifier-type (if int - `(integer ,(or (interval-low int) '*) - ,(or (interval-high int) '*)) - 'integer)))))) - (cond ((or y-integerp x-integerp) - (let ((interval (type-approximate-interval constraint t))) - (int interval y x) - (int interval x y))) - ((or (csubtypep (lvar-type x) (specifier-type 'real)) - (csubtypep (lvar-type y) (specifier-type 'real))) - (add x (specifier-type 'rational)) - (add y (specifier-type 'rational))))))) - ((csubtypep constraint (specifier-type 'real)) - (let ((x-realp (csubtypep (lvar-type x) (specifier-type 'real))) - (y-realp (csubtypep (lvar-type y) (specifier-type 'real)))) - (cond ((and x-realp - (not y-realp)) - (add y (specifier-type 'real))) - ((and y-realp - (not x-realp)) - (add x (specifier-type 'real))))))))))) + (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)))) + (flet ((int (c-interval x y) + (let* ((y-interval (type-approximate-interval (lvar-type y) t)) + (int (and c-interval y-interval + (interval-sub c-interval y-interval)))) + (add x (specifier-type (if int + `(integer ,(or (interval-low int) '*) + ,(or (interval-high int) '*)) + 'integer)))))) + (when (or y-integerp x-integerp) + (let ((interval (type-approximate-interval constraint t))) + (int interval y x) + (int interval x y)) + t))))) + (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)) @@ -64,10 +101,10 @@ (let ((var (ok-lvar-lambda-var lvar gen))) (when var (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) - (cond ((csubtypep constraint (specifier-type 'integer)) - (let ((x-integerp (csubtypep (lvar-type x) (specifier-type 'integer))) - (y-integerp (csubtypep (lvar-type y) (specifier-type 'integer)))) - (cond ((or y-integerp x-integerp) + (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)))) + (when (or y-integerp x-integerp) (let ((c-interval (type-approximate-interval constraint t))) (let* ((y-interval (type-approximate-interval (lvar-type y) t)) (int (and c-interval @@ -84,20 +121,10 @@ (add y (specifier-type (if int `(integer ,(or (interval-low int) '*) ,(or (interval-high int) '*)) - 'integer)))))) - ((or (csubtypep (lvar-type x) (specifier-type 'real)) - (csubtypep (lvar-type y) (specifier-type 'real))) - (add x (specifier-type 'rational)) - (add y (specifier-type 'rational)))))) - ((csubtypep constraint (specifier-type 'real)) - (let ((x-realp (csubtypep (lvar-type x) (specifier-type 'real))) - (y-realp (csubtypep (lvar-type y) (specifier-type 'real)))) - (cond ((and x-realp - (not y-realp)) - (add y (specifier-type 'real))) - ((and y-realp - (not x-realp)) - (add x (specifier-type 'real))))))))))) + 'integer))))) + t)))) + (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)) @@ -107,57 +134,52 @@ (let ((var (ok-lvar-lambda-var lvar gen))) (when var (conset-add-constraint-to-eql gen 'typep var type nil consequent))))) - (let* ((complex-p (or (types-equal-or-intersect (lvar-type x) (specifier-type 'complex)) - (types-equal-or-intersect (lvar-type x) (specifier-type 'complex)))) - ;; complex rationals multiplied by 0 will produce an integer 0. - (real-type (if complex-p - (specifier-type '(and real (not (eql 0)))) - (specifier-type 'real)))) - (cond ((csubtypep constraint (specifier-type 'integer)) - (let* ((rational-type (if complex-p - (specifier-type '(and rational (not (eql 0)))) - (specifier-type 'rational))) - (x-rationalp (csubtypep (lvar-type x) rational-type)) - (y-rationalp (csubtypep (lvar-type y) rational-type))) - (flet ((int (c-interval x y) - (let* ((y-interval (type-approximate-interval (lvar-type y) t)) - (int (and c-interval - y-interval - (interval-div c-interval y-interval)))) - (add x (specifier-type (if int - `(rational ,(or (interval-low int) '*) - ,(or (interval-high int) '*)) - 'rational)))))) - (cond ((or y-rationalp x-rationalp) - (let ((interval (type-approximate-interval constraint t)) - (x-zerop (types-equal-or-intersect (lvar-type x) (specifier-type '(eql 0)))) - (y-zerop (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0))))) - (cond ((not interval)) - ((and (interval-contains-p 0 interval) - (or x-zerop y-zerop)) - ;; If one is not zero the other must include a zero - (if x-zerop - (add y (specifier-type 'rational)) - (int interval y x)) - (if y-zerop - (add x (specifier-type 'rational)) - (int interval x y))) - (t - (int interval y x) - (int interval x y))))) - ((or (csubtypep (lvar-type x) real-type) - (csubtypep (lvar-type y) real-type)) - (add x (specifier-type 'rational)) - (add y (specifier-type 'rational))))))) - ((csubtypep constraint (specifier-type 'real)) - (let ((x-realp (csubtypep (lvar-type x) real-type)) - (y-realp (csubtypep (lvar-type y) real-type))) - (cond ((and x-realp - (not y-realp)) - (add y (specifier-type 'real))) - ((and y-realp - (not x-realp)) - (add x (specifier-type 'real)))))))))))) + (let ((complex-p (or (types-equal-or-intersect (lvar-type x) (specifier-type 'complex)) + (types-equal-or-intersect (lvar-type y) (specifier-type 'complex))))) + (cond ((and + (csubtypep constraint (specifier-type 'integer)) + (let* ((rational-type (if complex-p + (specifier-type '(and rational (not (eql 0)))) + (specifier-type 'rational))) + (x-rationalp (csubtypep (lvar-type x) rational-type)) + (y-rationalp (csubtypep (lvar-type y) rational-type))) + (flet ((int (c-interval x y) + (let* ((y-interval (type-approximate-interval (lvar-type y) t)) + (int (and c-interval + y-interval + (interval-div c-interval y-interval)))) + (add x (specifier-type (if int + `(rational ,(or (interval-low int) '*) + ,(or (interval-high int) '*)) + 'rational)))))) + (when (or y-rationalp x-rationalp) + (let ((interval (type-approximate-interval constraint t)) + (x-zerop (types-equal-or-intersect (lvar-type x) (specifier-type '(eql 0)))) + (y-zerop (types-equal-or-intersect (lvar-type y) (specifier-type '(eql 0))))) + (cond ((not interval) + nil) + ((and (interval-contains-p 0 interval) + (or x-zerop y-zerop)) + ;; If one is not zero the other must include a zero + (if x-zerop + (add y (specifier-type 'rational)) + (int interval y x)) + (if y-zerop + (add x (specifier-type 'rational)) + (int interval x y)) + t) + (t + (int interval y x) + (int interval x y) + t)))))))) + (t + (numeric-contagion-constraint-back x y gen constraint consequent complex-p)))))))) + +(defoptimizer (/ constraint-propagate-back) ((x y) node nth-value kind constraint gen consequent alternative) + (declare (ignore nth-value alternative)) + (case kind + (typep + (numeric-contagion-constraint-back x y gen constraint consequent)))) (defoptimizers constraint-propagate-back (car cdr) ((x) node nth-value kind constraint gen consequent alternative) (declare (ignore nth-value alternative)) diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp index 8a8728cd8..ceec0c5a0 100644 --- a/tests/constraint.pure.lisp +++ b/tests/constraint.pure.lisp @@ -943,7 +943,7 @@ (lambda (x y) (when (integerp (+ x y)) x)) - (or number null)) + (or rational (complex rational) null)) (assert-type (lambda (x y) (declare (real y)) @@ -996,7 +996,7 @@ (declare ((real 0 3) m)) (when (typep (* x m) '(integer 0 10)) x)) - (or number null)) + (or (or rational (complex rational) null) null)) (assert-type (lambda (x) (when (> (* x 3) 10) -- cgit v1.2.3-70-g09d2