master: Propagate that after (/= (rem n d) 0) D is (not (integer -1 1))

The branch "master" has been updated in SBCL:
       via  87930f9417b8c88c5fdc36595837ba577fb4e533 (commit)
      from  5d6cba27663dba7374d7bcc6d8cce2d0db370a8b (commit)

- Log -----------------------------------------------------------------
commit 87930f9417b8c88c5fdc36595837ba577fb4e533
Author: Stas Boukarev <[email protected]>
Date:   Thu Apr 9 21:33:47 2026 +0300

    Propagate that after (/= (rem n d) 0) D is (not (integer -1 1))
---
 src/compiler/constraint-back.lisp | 23 +++++++++++++++++------
 tests/constraint.pure.lisp        | 37 +++++++++++++++++++++++++------------
 2 files changed, 42 insertions(+), 18 deletions(-)

diff --git a/src/compiler/constraint-back.lisp b/src/compiler/constraint-back.lisp
index ad2d8b643..73fed0401 100644
--- a/src/compiler/constraint-back.lisp
+++ b/src/compiler/constraint-back.lisp
@@ -321,22 +321,33 @@
            (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))
 (defoptimizer (truncate constraint-propagate-back) ((x d) node nth-value kind constraint gen consequent alternative)
-  (let ((var (ok-lvar-lambda-var x gen)))
+  (let ((var (ok-lvar-lambda-var x gen))
+        (divisor-var (ok-lvar-lambda-var d gen)))
     (cond
       ((and var
             (eql nth-value 1)
-            (csubtypep (lvar-type x) (specifier-type 'integer))
-            (csubtypep (lvar-type d) (specifier-type 'integer)))
+            (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)))
+            (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 (csubtypep (lvar-type constraint) (specifier-type '(integer 0)))
-            (conset-add-constraint-to-eql gen 'typep var (specifier-type '(integer 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))))
+         (<
+          (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))))))
       ((eq kind 'typep)
        (if (eql nth-value 1)
            (cond ((and (csubtypep constraint (specifier-type 'integer))
diff --git a/tests/constraint.pure.lisp b/tests/constraint.pure.lisp
index 846f4db39..f3914f585 100644
--- a/tests/constraint.pure.lisp
+++ b/tests/constraint.pure.lisp
@@ -535,18 +535,31 @@
     '(values integer &optional))))
 
 (with-test (:name :truncate-zero-remainder)
-  (assert
-   (type-specifiers-equal
-    (caddr
-     (sb-kernel:%simple-fun-type
-      (checked-compile
-       `(lambda (x y)
-          (declare (integer x y))
-          (multiple-value-bind (q r) (truncate x y)
-            (if (zerop r)
-                (error "~a" q)
-                x))))))
-    '(values (or (integer * -1) (integer 1)) &optional))))
+  (assert-type
+   (lambda (x y)
+     (declare (integer x y))
+     (multiple-value-bind (q r) (truncate x y)
+       (if (zerop r)
+           (error "~a" q)
+           (values x y))))
+   (values (or (integer * -1) (integer 1))
+           (or (integer * -2) (integer 2)) &optional))
+  (assert-type
+   (lambda (x y)
+     (declare (integer x y))
+     (multiple-value-bind (q r) (truncate x y)
+       (if (> r 0)
+           (values x y)
+           (error "~a" q))))
+   (values (integer 1) (or (integer * -2) (integer 2)) &optional))
+  (assert-type
+   (lambda (x y)
+     (declare (integer x y))
+     (multiple-value-bind (q r) (truncate x y)
+       (if (< r 0)
+           (values x y)
+           (error "~a" q))))
+   (values (integer * -1) (or (integer * -2) (integer 2)) &optional)))
 
 (with-test (:name :vector-length-var)
   (assert

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL