Skip to content
Browse files

Merge branch 'master' into mswinmt

  • Loading branch information...
2 parents 518f350 + 5a2c881 commit d7a18166a876d8a5091500e018412d8bff54bb8e @akovalenko committed Jan 23, 2012
Showing with 75 additions and 26 deletions.
  1. +3 −0 NEWS
  2. +4 −2 src/compiler/array-tran.lisp
  3. +56 −24 src/compiler/checkgen.lisp
  4. +12 −0 tests/compiler.pure.lisp
View
3 NEWS
@@ -1,4 +1,7 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
+changes relative to sbcl-1.0.55:
+ * bug fix: compiler errors when weakening hairy integer types. (lp#913232)
+
changes in sbcl-1.0.55 relative to sbcl-1.0.54:
* enhancements to building SBCL using make.sh:
** --fancy can be specified to enable all supported feature enhancements.
View
6 src/compiler/array-tran.lisp
@@ -180,9 +180,11 @@
(flet ((subscript-bounds (subscript)
(let* ((type1 (lvar-type subscript))
(type2 (if (csubtypep type1 (specifier-type 'integer))
- (weaken-integer-type type1)
+ (weaken-integer-type type1 :range-only t)
(give-up)))
- (low (numeric-type-low type2))
+ (low (if (integer-type-p type2)
+ (numeric-type-low type2)
+ (give-up)))
(high (numeric-type-high type2)))
(cond
((and (or (not (bound-known-p low)) (minusp low))
View
80 src/compiler/checkgen.lisp
@@ -77,27 +77,58 @@
(t
(fun-guessed-cost 'typep)))))
-(defun weaken-integer-type (type)
- (cond ((union-type-p type)
- (let* ((types (union-type-types type))
- (one (pop types))
- (low (numeric-type-low one))
- (high (numeric-type-high one)))
- (flet ((maximize (bound)
- (if (and bound high)
- (setf high (max high bound))
- (setf high nil)))
- (minimize (bound)
- (if (and bound low)
- (setf low (min low bound))
- (setf low nil))))
- (dolist (a types)
- (minimize (numeric-type-low a))
- (maximize (numeric-type-high a))))
- (specifier-type `(integer ,(or low '*) ,(or high '*)))))
- (t
- (aver (integer-type-p type))
- type)))
+(defun weaken-integer-type (type &key range-only)
+ ;; FIXME: Our canonicalization isn't quite ideal for this. We get
+ ;; types such as:
+ ;;
+ ;; (OR (AND (SATISFIES FOO) (INTEGER -100 -50))
+ ;; (AND (SATISFIES FOO) (INTEGER 100 200)))
+ ;;
+ ;; here, and weakening that into
+ ;;
+ ;; (AND (SATISFIES FOO) (INTEGER -100 200))
+ ;;
+ ;; is too much work to do here ... but if we canonicalized things
+ ;; differently, we could get it for free with trivial changes here.
+ (labels ((weaken-integer-type-part (type base)
+ (cond ((intersection-type-p type)
+ (let ((new (specifier-type base)))
+ (dolist (part (intersection-type-types type))
+ (when (if range-only
+ (numeric-type-p part)
+ (not (unknown-type-p part)))
+ (setf new (type-intersection
+ new (weaken-integer-type-part part t)))))
+ new))
+ ((union-type-p type)
+ (let ((low t) (high t) (rest *empty-type*))
+ (flet ((maximize (bound)
+ (if (and bound high)
+ (setf high (if (eq t high)
+ bound
+ (max high bound)))
+ (setf high nil)))
+ (minimize (bound)
+ (if (and bound low)
+ (setf low (if (eq t low)
+ bound
+ (min low bound)))
+ (setf low nil))))
+ (dolist (part (union-type-types type))
+ (let ((weak (weaken-integer-type-part part t)))
+ (cond ((numeric-type-p weak)
+ (minimize (numeric-type-low weak))
+ (maximize (numeric-type-high weak)))
+ ((not range-only)
+ (setf rest (type-union rest weak)))))))
+ (if (eq t low)
+ rest
+ (type-union rest
+ (specifier-type
+ `(integer ,(or low '*) ,(or high '*)))))))
+ (t
+ type))))
+ (weaken-integer-type-part type 'integer)))
(defun-cached
(weaken-type :hash-bits 8
@@ -108,9 +139,10 @@
(cond ((named-type-p type)
type)
((csubtypep type (specifier-type 'integer))
- ;; KLUDGE: Simple range checks are not that expensive, and we *don't*
- ;; want to accidentally lose eg. array bounds checks due to weakening,
- ;; so for integer types we simply collapse all ranges into one.
+ ;; Simple range checks are not that expensive, and we *don't*
+ ;; want to accidentally lose eg. array bounds checks due to
+ ;; weakening, so for integer types we simply collapse all
+ ;; ranges into one.
(weaken-integer-type type))
(t
(let ((min-cost (type-test-cost type))
View
12 tests/compiler.pure.lisp
@@ -4167,3 +4167,15 @@
(declare (type (integer -1 -1) d))
(let ((i (unwind-protect 32 (shiftf d -1))))
(or (if (= d c) 2 (= 3 b)) 4)))))
+
+(with-test (:name :bug-913232)
+ (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (or (and (or (integer -100 -50)
+ (integer 100 200)) (satisfies foo))
+ (and (or (integer 0 10) (integer 20 30)) a)) x))
+ x))
+ (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (and fixnum a) x))
+ x)))

0 comments on commit d7a1816

Please sign in to comment.
Something went wrong with that request. Please try again.