master: Warn about integer division by zero
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 621a78e63f2e9494d9a555ebfb5c1e179f0a28b7 (commit)
from 52250de6b879671adca0e1986fef4e4910064ce2 (commit)
- Log -----------------------------------------------------------------
commit 621a78e63f2e9494d9a555ebfb5c1e179f0a28b7
Author: Stas Boukarev <[email protected]>
Date: Wed Apr 8 22:17:43 2026 +0300
Warn about integer division by zero
---
src/compiler/srctran.lisp | 57 ++++++++++++++++++++++++++++++++++-----------
tests/arith.pure.lisp | 20 +++++++---------
tests/backtrace.impure.lisp | 37 -----------------------------
tests/compiler-2.pure.lisp | 2 +-
4 files changed, 53 insertions(+), 63 deletions(-)
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c39bde4ec..842064441 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2158,8 +2158,13 @@
(t
(numeric-contagion x y))))
-(defoptimizer (/ derive-type) ((x y))
- (two-arg-derive-type x y #'/-derive-type-aux))
+(defoptimizer (/ derive-type) ((x y) node)
+ (let ((type (two-arg-derive-type x y #'/-derive-type-aux)))
+ (when (eq type *empty-type*)
+ (let ((*compiler-error-context* node))
+ (setf (combination-kind node) :error
+ (combination-info node) (list #'compiler-warn "division by zero"))))
+ type))
(defconstant +left-shift-derive-type-cutoff+ 256)
@@ -2397,6 +2402,10 @@
(make-quot (second div))))
(t
(make-quot div))))))
+ ((and float
+ (rational-type-p number-type)
+ (eq divisor-type (specifier-type '(eql 0))))
+ *empty-type*)
(t
(multiple-value-bind (quot conservative)
(if (and (member (interval-high divisor-interval) '(1 1f0 1d0))
@@ -2481,13 +2490,18 @@
(t
(numeric-contagion num div))))
-(defoptimizer (truncate derive-type) ((number divisor))
+(defoptimizer (truncate derive-type) ((number divisor) node)
(let ((quot (two-arg-derive-type number divisor
#'truncate-derive-type-quot-aux))
(rem (two-arg-derive-type number divisor
#'truncate-derive-type-rem-aux)))
- (when (and quot rem)
- (make-values-type (list quot rem)))))
+ (if (eq quot *empty-type*)
+ (let ((*compiler-error-context* node))
+ (setf (combination-kind node) :error
+ (combination-info node) (list #'compiler-warn "division by zero"))
+ quot)
+ (when (and quot rem)
+ (make-values-type (list quot rem))))))
(defun %unary-truncate-derive-type-aux (number)
(truncate-derive-type-quot number (specifier-type '(integer 1 1))))
@@ -2525,15 +2539,20 @@
(numeric-type-format
(numeric-contagion number-type divisor-type :float t)))))
-(defoptimizer (ftruncate derive-type) ((number &optional divisor))
+(defoptimizer (ftruncate derive-type) ((number &optional divisor) node)
(let* ((divisor (if divisor
(lvar-type divisor)
(specifier-type '(eql 1))))
(number (lvar-type number))
(quot (%two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux))
(rem (%two-arg-derive-type number divisor #'truncate-derive-type-rem-aux)))
- (when (and quot rem)
- (make-values-type (list quot rem)))))
+ (if (eq quot *empty-type*)
+ (let ((*compiler-error-context* node))
+ (setf (combination-kind node) :error
+ (combination-info node) (list #'compiler-warn "division by zero"))
+ quot)
+ (when (and quot rem)
+ (make-values-type (list quot rem))))))
(defun fceiling-derive-type-quot-aux (number-type divisor-type same-arg)
(declare (ignore same-arg))
@@ -2543,15 +2562,20 @@
(numeric-type-format
(numeric-contagion number-type divisor-type :float t)))))
-(defoptimizer (fceiling derive-type) ((number &optional divisor))
+(defoptimizer (fceiling derive-type) ((number &optional divisor) node)
(let* ((divisor (if divisor
(lvar-type divisor)
(specifier-type '(eql 1))))
(number (lvar-type number))
(quot (%two-arg-derive-type number divisor #'fceiling-derive-type-quot-aux))
(rem (%two-arg-derive-type number divisor #'ceiling-rem-bound-aux)))
- (when (and quot rem)
- (make-values-type (list quot rem)))))
+ (if (eq quot *empty-type*)
+ (let ((*compiler-error-context* node))
+ (setf (combination-kind node) :error
+ (combination-info node) (list #'compiler-warn "division by zero"))
+ quot)
+ (when (and quot rem)
+ (make-values-type (list quot rem))))))
(defun ffloor-derive-type-quot-aux (number-type divisor-type same-arg)
(declare (ignore same-arg))
@@ -2561,15 +2585,20 @@
(numeric-type-format
(numeric-contagion number-type divisor-type :float t)))))
-(defoptimizer (ffloor derive-type) ((number &optional divisor))
+(defoptimizer (ffloor derive-type) ((number &optional divisor) node)
(let* ((divisor (if divisor
(lvar-type divisor)
(specifier-type '(eql 1))))
(number (lvar-type number))
(quot (%two-arg-derive-type number divisor #'ffloor-derive-type-quot-aux))
(rem (%two-arg-derive-type number divisor #'floor-rem-bound-aux)))
- (when (and quot rem)
- (make-values-type (list quot rem)))))
+ (if (eq quot *empty-type*)
+ (let ((*compiler-error-context* node))
+ (setf (combination-kind node) :error
+ (combination-info node) (list #'compiler-warn "division by zero"))
+ quot)
+ (when (and quot rem)
+ (make-values-type (list quot rem))))))
(macrolet ((derive (type)
diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index ac18ee6c8..1e6f0c65f 100644
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -43,7 +43,7 @@
(() (condition 'division-by-zero))))
(with-test (:name (/ :division-by-zero bignum))
- (checked-compile-and-assert (:allow-style-warnings t)
+ (checked-compile-and-assert (:allow-warnings t)
'(lambda () (/ (1+ most-positive-fixnum) 0))
(() (condition 'division-by-zero))))
@@ -282,7 +282,8 @@
(let ((fn (checked-compile
`(lambda (x)
(declare (optimize speed) (fixnum x))
- (,name x 0)))))
+ (,name x 0))
+ :allow-warnings t)))
(assert-error (funcall fn 1) division-by-zero))))
(mapc #'frob '(mod truncate rem / floor ceiling))))
@@ -475,7 +476,7 @@
`(lambda ,vars
(declare (notinline ,op))
(,op ,@args))
- :allow-style-warnings (eq op '/))))
+ :allow-warnings (eq op '/))))
(loop repeat 3
do (let* ((call-args (loop repeat (length vars)
collect (- (random 21) 10)))
@@ -841,14 +842,11 @@
'(#x9516A7 #x2531b4 0 0))))))
(with-test (:name :truncate-by-zero-derivation)
- (assert
- (not (equal (cadr
- (cdaddr (sb-kernel:%simple-fun-type
- (checked-compile
- `(lambda ()
- (truncate 5 0))
- :allow-style-warnings t))))
- '(integer 0 0)))))
+ (assert-type
+ (lambda ()
+ (declare (muffle-conditions warning))
+ (truncate 5 0))
+ nil))
(with-test (:name :truncate-by-zero-derivation.2)
(checked-compile
diff --git a/tests/backtrace.impure.lisp b/tests/backtrace.impure.lisp
index 3da79ce4b..b44c14773 100644
--- a/tests/backtrace.impure.lisp
+++ b/tests/backtrace.impure.lisp
@@ -224,43 +224,6 @@
(sb-thread:condition-wait q m)))))
`((sb-thread::%condition-wait ,q ,m t nil nil nil nil nil nil)))))
-;;; Division by zero was a common error on PPC. It depended on the
-;;; return function either being before INTEGER-/-INTEGER in memory,
-;;; or more than MOST-POSITIVE-FIXNUM bytes ahead. It also depends on
-;;; INTEGER-/-INTEGER calling SIGNED-TRUNCATE. I believe Raymond Toy
-;;; says that the Sparc backend (at least for CMUCL) inlines this, so
-;;; if SBCL does the same this test is probably not good for the
-;;; Sparc.
-;;;
-;;; Disabling tail call elimination on this will probably ensure that
-;;; the return value (to the flet or the enclosing top level form) is
-;;; more than MOST-POSITIVE-FIXNUM with the current spaces on OS X.
-;;; Enabling it might catch other problems, so do it anyway.
-(flet ((optimized ()
- (declare (optimize (speed 2) (debug 1))) ; tail call elimination
- (declare (muffle-conditions style-warning))
- (/ 42 0))
- (not-optimized ()
- (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
- (declare (muffle-conditions style-warning))
- (/ 42 0))
- (test (fun)
- (declare (optimize (speed 1) (debug 3))) ; no tail call elimination
- (funcall fun)))
-
- (with-test (:name (:backtrace :divide-by-zero :bug-346)
- :skipped-on :interpreter)
- (assert-backtrace (lambda () (test #'optimized))
- `((/ 42 &rest)
- ((flet test :in ,*p*) ,#'optimized))))
-
- (with-test (:name (:backtrace :divide-by-zero :bug-356)
- :skipped-on :interpreter)
- (assert-backtrace (lambda () (test #'not-optimized))
- `((/ 42 &rest)
- ((flet not-optimized :in ,*p*))
- ((flet test :in ,*p*) ,#'not-optimized)))))
-
(defun throw-test ()
(throw 'no-such-tag t))
(with-test (:name (:backtrace :throw :no-such-tag)
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 7351f01e9..ca3ecaf10 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -4953,7 +4953,7 @@
(with-test (:name :unused-tns-erased-types)
(checked-compile-and-assert
- (:optimize :safe)
+ (:optimize :safe :allow-warnings t)
'(lambda (x)
(declare ((integer 10 20) x))
(let ((q (truncate (/ x 0))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL