master: Narrow the type of (truncate n d) based on the remainder
stassats via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via b8fa70041c0c0819bb18a46f96452e99d760fccd (commit)
from 9190402f7088f04df927851e8a345400c6366cc7 (commit)
- Log -----------------------------------------------------------------
commit b8fa70041c0c0819bb18a46f96452e99d760fccd
Author: Stas Boukarev <[email protected]>
Date: Fri Apr 10 01:47:29 2026 +0300
Narrow the type of (truncate n d) based on the remainder
If the remainder is non-zero then the divisor is at least 2, cutting
the quotient range in half.
---
src/code/type.lisp | 31 +++++++++++++
src/compiler/constraint-back.lisp | 92 +++++++++++++++++++++++++++++++--------
src/compiler/constraint.lisp | 11 +++--
src/compiler/ir1util.lisp | 22 ++++++----
tests/constraint.pure.lisp | 48 +++++++++++++++++++-
5 files changed, 172 insertions(+), 32 deletions(-)
diff --git a/src/code/type.lisp b/src/code/type.lisp
index 97481a77a..8c91d3dfb 100644
--- a/src/code/type.lisp
+++ b/src/code/type.lisp
@@ -7020,6 +7020,37 @@ expansion happened."
(values (aref ranges 1) (aref ranges (1- (length ranges))))
(values (aref ranges 0) (aref ranges (1- (length ranges)))))))
+;; (or (integer * -3) (integer 5)) => -3, 5
+;; (integer 5) => nil, 5
+;; (integer * -5) => -5, nil
+;; (integer -5 5) => 0, 0
+(defun numeric-union-min-abs-bounds (type)
+ (let ((ranges (numeric-union-type-ranges type))
+ (aspects (numeric-union-type-aspects type))
+ min-left
+ min-right)
+ (block nil
+ (flet ((process (low high)
+ (cond ((not (fp-high-ge-high-p high 0))
+ (setf min-left high))
+ ((not (fp-low-le-low-p low 0))
+ (setf min-right low)
+ (return))
+ (t
+ (setf min-left 0
+ min-right 0)
+ (return)))))
+ (if (memq (numtype-aspects-class aspects) '(integer rational))
+ (loop for i below (length ranges) by 3
+ for low = (aref ranges (+ i 1))
+ for high = (aref ranges (+ i 2))
+ do (process low high))
+ (loop for i below (length ranges) by 2
+ for low = (aref ranges i)
+ for high = (aref ranges (1+ i))
+ do (process low high)))))
+ (values min-left min-right)))
+
(defun weaken-numeric-union (type)
(let ((ranges (numeric-union-type-ranges type))
(aspects (numeric-union-type-aspects type)))
diff --git a/src/compiler/constraint-back.lisp b/src/compiler/constraint-back.lisp
index 73fed0401..05a0036bd 100644
--- a/src/compiler/constraint-back.lisp
+++ b/src/compiler/constraint-back.lisp
@@ -321,7 +321,7 @@
(conset-add-constraint-to-eql gen 'typep var (specifier-type '(not null)) nil consequent)))))))
;;; If the remainder is non-zero then X can't be zero.
-;;; And the divisior is (not (integer -1 1))
+;;; And the divisor is (not (integer -1 1))
(defoptimizer (truncate constraint-propagate-back) ((x d) node nth-value kind constraint gen consequent alternative)
(let ((var (ok-lvar-lambda-var x gen))
(divisor-var (ok-lvar-lambda-var d gen)))
@@ -330,24 +330,78 @@
(eql nth-value 1)
(lvar-csubtypep x integer)
(lvar-csubtypep d integer))
- (case kind
- (eql
- (when (and (constant-p constraint)
- (eql (constant-value constraint) 0)
- alternative)
- (conset-add-constraint-to-eql gen 'typep var (specifier-type '(and integer (not (eql 0)))) nil alternative)
- (when divisor-var
- (conset-add-constraint-to-eql gen 'typep divisor-var (specifier-type '(and integer (not (integer -1 1)))) nil alternative))))
- (>
- (when (lvar-csubtypep constraint (integer 0))
- (conset-add-constraint-to-eql gen 'typep var (specifier-type '(integer 1)) nil consequent)
- (when divisor-var
- (conset-add-constraint-to-eql gen 'typep divisor-var (specifier-type '(and integer (not (integer -1 1)))) nil consequent))))
- (<
- (when (lvar-csubtypep constraint (integer * 0))
- (conset-add-constraint-to-eql gen 'typep var (specifier-type '(integer * -1)) nil consequent)
- (when divisor-var
- (conset-add-constraint-to-eql gen 'typep divisor-var (specifier-type '(and integer (not (integer -1 1)))) nil consequent))))))
+ (flet ((derive-quot (target &optional sign)
+ ;; If the remainder is non-zero then the divisor is at least 2
+ (let* ((q (first (mv-bind-vars (node-lvar node))))
+ (q-var (and (ok-lambda-var q)
+ ;; In lieu of knowing if it's still EQ
+ (not (lambda-var-sets q))
+ q)))
+ (when q-var
+ (let* ((x-type (lvar-type x))
+ (x-int (type-approximate-interval x-type t))
+ (d-type (type-intersection
+ (lvar-type d)
+ (specifier-type '(and integer (not (integer -1 1))))))
+ (min (or (multiple-value-bind (left right)
+ (if (numeric-union-type-p d-type)
+ (sb-kernel::numeric-union-min-abs-bounds d-type)
+ (values -2 2))
+ (cond ((and left right)
+ (min (abs left)
+ (abs right)))
+ (left
+ (abs left))
+ (right
+ (abs right)))))))
+ (when x-int
+ ;; Not interested in even bounds
+ (let ((new-low (and (interval-low x-int)
+ (< (interval-low x-int) 0)
+ (zerop (rem (interval-low x-int) min))
+ (1+ (interval-low x-int))))
+ (new-high (and (interval-high x-int)
+ (> (interval-high x-int) 0)
+ (zerop (rem (interval-high x-int) min))
+ (1- (interval-high x-int)))))
+ (when (or new-low new-high)
+ (setf x-type
+ (make-numeric-type :class 'integer
+ :low (or new-low
+ (interval-low x-int))
+ :high (or new-high
+ (interval-high x-int)))))))
+
+ (when sign
+ (setf x-type (type-intersection x-type sign)))
+ (let ((type (%two-arg-derive-type x-type d-type
+ #'truncate-derive-type-quot-aux)))
+ (when (and type
+ (not (numeric-type-without-bounds-p type)))
+ (conset-add-constraint-to-eql gen 'typep q-var
+ type
+ nil target))))))))
+ (case kind
+ (eql
+ (when (and (constant-p constraint)
+ (eql (constant-value constraint) 0)
+ alternative)
+ (conset-add-constraint-to-eql gen 'typep var (specifier-type '(and integer (not (eql 0)))) nil alternative)
+ (derive-quot alternative)
+ (when divisor-var
+ (conset-add-constraint-to-eql gen 'typep divisor-var (specifier-type '(and integer (not (integer -1 1)))) nil alternative))))
+ (>
+ (when (lvar-csubtypep constraint (integer 0))
+ (conset-add-constraint-to-eql gen 'typep var (specifier-type '(integer 1)) nil consequent)
+ (derive-quot consequent (specifier-type '(integer 1)))
+ (when divisor-var
+ (conset-add-constraint-to-eql gen 'typep divisor-var (specifier-type '(and integer (not (integer -1 1)))) nil consequent))))
+ (<
+ (when (lvar-csubtypep constraint (integer * 0))
+ (conset-add-constraint-to-eql gen 'typep var (specifier-type '(integer * -1)) nil consequent)
+ (derive-quot consequent (specifier-type '(integer * -1)))
+ (when divisor-var
+ (conset-add-constraint-to-eql gen 'typep divisor-var (specifier-type '(and integer (not (integer -1 1)))) nil consequent)))))))
((eq kind 'typep)
(if (eql nth-value 1)
(cond ((and (csubtypep constraint (specifier-type 'integer))
diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 46f977b0c..58ab921fa 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -589,15 +589,18 @@
(inherit-constraints (eql2) var1 constraints target))
t)))
+(declaim (inline ok-lambda-var))
+(defun ok-lambda-var (lambda-var)
+ (when (and (lambda-var-p lambda-var)
+ (lambda-var-constraints lambda-var))
+ lambda-var))
+
;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
(declaim (inline ok-ref-lambda-var))
(defun ok-ref-lambda-var (ref)
(declare (type ref ref))
- (let ((leaf (ref-leaf ref)))
- (when (and (lambda-var-p leaf)
- (lambda-var-constraints leaf))
- leaf)))
+ (ok-lambda-var (ref-leaf ref)))
;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 552e3e064..72775f7a9 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -323,7 +323,8 @@
do (return (values (lvar-dest lvar) lvar ref))))
(values dest lvar)))))))
-(defun mv-bind-dest (lvar nth-value &optional single-use)
+
+(defun mv-bind-vars (lvar &optional single-use)
(when (and lvar
(or (not single-use)
(atom (lvar-uses lvar))))
@@ -331,13 +332,18 @@
(when (and (mv-combination-p dest)
(eq (basic-combination-kind dest) :local))
(let ((fun (combination-lambda dest)))
- (let* ((var (nth nth-value (lambda-vars fun)))
- (refs (leaf-refs var)))
- (when (and refs
- (not (cdr refs))
- (not (lambda-var-sets var)))
- (when (functional-kind-eq fun mv-let)
- (let-lvar-dest (node-lvar (car refs)) single-use)))))))))
+ (when (functional-kind-eq fun mv-let)
+ (lambda-vars fun)))))))
+
+(defun mv-bind-dest (lvar nth-value &optional single-use)
+ (let ((vars (mv-bind-vars lvar single-use)))
+ (when vars
+ (let* ((var (nth nth-value vars))
+ (refs (leaf-refs var)))
+ (when (and refs
+ (not (cdr refs))
+ (not (lambda-var-sets var)))
+ (let-lvar-dest (node-lvar (car refs)) single-use))))))
(defun mv-bind-unused-p (lvar nth-value)
(when lvar
diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp
index f3914f585..3e0605655 100644
--- a/tests/constraint.pure.lisp
+++ b/tests/constraint.pure.lisp
@@ -559,7 +559,53 @@
(if (< r 0)
(values x y)
(error "~a" q))))
- (values (integer * -1) (or (integer * -2) (integer 2)) &optional)))
+ (values (integer * -1) (or (integer * -2) (integer 2)) &optional))
+ (assert-type
+ (lambda (n d)
+ (declare ((integer -10 10) n)
+ (integer d))
+ (multiple-value-bind (q r) (truncate n d)
+ (declare (ignorable q r))
+ (when (> r 0)
+ q)))
+ (or (integer -4 4) null))
+ (assert-type
+ (lambda (n d)
+ (declare ((integer -11 10) n)
+ (unsigned-byte d))
+ (multiple-value-bind (q r) (truncate n d)
+ (declare (ignorable q r))
+ (when (/= r 0)
+ q)))
+ (or (integer -5 4) null))
+ (assert-type
+ (lambda (n d)
+ (declare ((integer -11 10) n)
+ (unsigned-byte d))
+ (multiple-value-bind (q r) (truncate n d)
+ (declare (ignorable q r))
+ (when (< r 0)
+ q)))
+ (or (integer -5 0) null))
+ (assert-type
+ (lambda (n d)
+ (declare ((integer -11 10) n)
+ (unsigned-byte d))
+ (multiple-value-bind (q r) (truncate n d)
+ (declare (ignorable q r))
+ (when (> r 0)
+ q)))
+ (or (integer 0 4) null))
+ (assert-type
+ (lambda (n d)
+ (declare ((integer -25 25) n)
+ ((or (integer * -5) (integer 5)) d)
+ (optimize (debug 1)))
+ (multiple-value-bind (q r) (truncate n d)
+ (declare (ignorable q r))
+ (when (> r 0)
+ q)))
+ (or null (integer -4 4))))
(with-test (:name :vector-length-var)
(assert
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL