in the DEFMETHOD body.
* bug fix: #<SB-C::DEFINED-FUN ...> should no longer appear in compiler
messages, being instead replaced with the corresponding function name.
+ * bug fix: don't derive overly complex unions of numeric types for arithmetic
+ operators. (lp#309448)
changes in sbcl-1.0.44 relative to sbcl-1.0.43:
* enhancement: RUN-PROGRAM accepts :EXTERNAL-FORMAT argument to select the
"%WITH-ARRAY-DATA"
"%WITH-ARRAY-DATA/FP"
"%WITH-ARRAY-DATA-MACRO"
+ "*APPROXIMATE-NUMERIC-UNIONS*"
"*CURRENT-LEVEL-IN-PRINT*"
"*EMPTY-TYPE*"
"*EVAL-CALLS*"
;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
;;;
-;;; Old comment, probably no longer applicable:
-;;;
-;;; ### Note: we give up early to keep from dropping lots of
-;;; information on the floor by returning overly general types.
+;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent
+;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128),
+;;; the compiler does this occasionally during type-derivation to avoid
+;;; creating absurdly complex unions of numeric types.
+(defvar *approximate-numeric-unions* nil)
+
(!define-type-method (number :simple-union2) (type1 type2)
(declare (type numeric-type type1 type2))
(cond ((csubtypep type1 type2) type2)
((and (eq class1 class2)
(eq format1 format2)
(eq complexp1 complexp2)
- (or (numeric-types-intersect type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-intersect type1 type2)
(numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
(integerp (numeric-type-low type2))
(integerp (numeric-type-high type2))
(= (numeric-type-low type2) (numeric-type-high type2))
- (or (numeric-types-adjacent type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
:class 'rational
(integerp (numeric-type-low type1))
(integerp (numeric-type-high type1))
(= (numeric-type-low type1) (numeric-type-high type1))
- (or (numeric-types-adjacent type1 type2)
+ (or *approximate-numeric-unions*
+ (numeric-types-adjacent type1 type2)
(numeric-types-adjacent type2 type1)))
(make-numeric-type
:class 'rational
(t
type-list)))
-;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
-;;; belong in the kernel's type logic, invoked always, instead of in
-;;; the compiler, invoked only during some type optimizations. (In
-;;; fact, as of 0.pre8.100 or so they probably are, under
-;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)
-
;;; Take a list of types and return a canonical type specifier,
;;; combining any MEMBER types together. If both positive and negative
;;; MEMBER types are present they are converted to a float type.
;;; XXX This would be far simpler if the type-union methods could handle
;;; member/number unions.
-(defun make-canonical-union-type (type-list)
+;;;
+;;; If we're about to generate an overly complex union of numeric types, start
+;;; collapse the ranges together.
+;;;
+;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
+;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
+;;; invoked always, instead of in the compiler, invoked only during some type
+;;; optimizations.
+(defvar *derived-numeric-union-complexity-limit* 6)
+
+(defun make-derived-union-type (type-list)
(let ((xset (alloc-xset))
(fp-zeroes '())
- (misc-types '()))
+ (misc-types '())
+ (numeric-type *empty-type*))
(dolist (type type-list)
(cond ((member-type-p type)
(mapc-member-type-members
(pushnew member fp-zeroes))
(add-to-xset member xset)))
type))
+ ((numeric-type-p type)
+ (let ((*approximate-numeric-unions*
+ (when (and (union-type-p numeric-type)
+ (nthcdr *derived-numeric-union-complexity-limit*
+ (union-type-types numeric-type)))
+ t)))
+ (setf numeric-type (type-union type numeric-type))))
(t
(push type misc-types))))
(if (and (xset-empty-p xset) (not fp-zeroes))
- (apply #'type-union misc-types)
- (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes) misc-types))))
+ (apply #'type-union numeric-type misc-types)
+ (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes)
+ numeric-type misc-types))))
;;; Convert a member type with a single member to a numeric type.
(defun convert-member-type (arg)
(setf results (append results result))
(push result results))))
(if (rest results)
- (make-canonical-union-type results)
+ (make-derived-union-type results)
(first results)))))))
;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
(setf results (append results result))
(push result results))))))
(if (rest results)
- (make-canonical-union-type results)
+ (make-derived-union-type results)
(first results)))))))
\f
#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(declare (boolean k1))
(declare (ignore x y k1))
t))))))
+
+(with-test (:name :bug-309448)
+ ;; Like all tests trying to verify that something doesn't blow up
+ ;; compile-times this is bound to be a bit brittle, but at least
+ ;; here we try to establish a decent baseline.
+ (flet ((time-it (lambda want)
+ (let* ((start (get-internal-run-time))
+ (fun (compile nil lambda))
+ (end (get-internal-run-time))
+ (got (funcall fun)))
+ (unless (eql want got)
+ (error "wanted ~S, got ~S" want got))
+ (- end start))))
+ (let ((time-1/simple
+ ;; This is mostly identical as the next one, but doesn't create
+ ;; hairy unions of numeric types.
+ (time-it `(lambda ()
+ (labels ((bar (baz bim)
+ (let ((n (+ baz bim)))
+ (* n (+ n 1) bim))))
+ (let ((a (bar 1 1))
+ (b (bar 1 1))
+ (c (bar 1 1)))
+ (- (+ a b) c))))
+ 6))
+ (time-1/hairy
+ (time-it `(lambda ()
+ (labels ((bar (baz bim)
+ (let ((n (+ baz bim)))
+ (* n (+ n 1) bim))))
+ (let ((a (bar 1 1))
+ (b (bar 1 5))
+ (c (bar 1 15)))
+ (- (+ a b) c))))
+ -3864)))
+ (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy)))
+ (let ((time-2/simple
+ ;; This is mostly identical as the next one, but doesn't create
+ ;; hairy unions of numeric types.
+ (time-it `(lambda ()
+ (labels ((sum-d (n)
+ (let ((m (truncate 999 n)))
+ (/ (* n m (1+ m)) 2))))
+ (- (+ (sum-d 3)
+ (sum-d 3))
+ (sum-d 3))))
+ 166833))
+ (time-2/hairy
+ (time-it `(lambda ()
+ (labels ((sum-d (n)
+ (let ((m (truncate 999 n)))
+ (/ (* n m (1+ m)) 2))))
+ (- (+ (sum-d 3)
+ (sum-d 5))
+ (sum-d 15))))
+ 233168)))
+ (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy)))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.44.27"
+"1.0.44.28"
projects / sbcl.git / commitdiff