Permalink
Browse files

teach NODE-CONSERVATIVE-TYPE about union types

  Conservative type of STRING is STRING -- and this makes it so.

  Fixes lp#1050768 (but also future-proof ARRAY-IN-BOUNDS-P against
  '*) explicitly.
  • Loading branch information...
1 parent 99440ad commit 7374cac4bf6ad3b9f109e4a4d0558325b2cad230 @nikodemus nikodemus committed Oct 7, 2012
Showing with 30 additions and 0 deletions.
  1. +2 −0 NEWS
  2. +5 −0 src/compiler/array-tran.lisp
  3. +7 −0 src/compiler/ir1opt.lisp
  4. +16 −0 tests/compiler.pure.lisp
View
2 NEWS
@@ -10,6 +10,8 @@ changes relative to sbcl-1.1.0:
(thanks to SANO Masatoshi)
* bug fix: PARSE-NATIVE-NAMESTRING performed non-native parsing when
:JUNK-ALLOWED was true.
+ * bug fix: type derivation inferred overly conservative types for
+ unions of array types. (lp#1050768)
changes in sbcl-1.1.0 relative to sbcl-1.0.58:
* enhancement: New variable, sb-ext:*disassemble-annotate* for controlling
@@ -169,6 +169,11 @@
(block nil
(let ((dimensions (array-type-dimensions-or-give-up
(lvar-conservative-type array))))
+ ;; Might be *. (Note: currently this is never true, because the type
+ ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but
+ ;; let's keep this future proof.)
+ (when (eq '* dimensions)
+ (give-up-ir1-transform "array bounds unknown"))
;; shortcut for zero dimensions
(when (some (lambda (dim)
(and (bound-known-p dim) (zerop dim)))
View
@@ -166,7 +166,14 @@
:specialized-element-type (array-type-specialized-element-type type))
;; Simple arrays cannot change at all.
type))
+ ((union-type-p type)
+ ;; Conservative union type is an union of conservative types.
+ (let ((res *empty-type*))
+ (dolist (part (union-type-types type) res)
+ (setf res (type-union res (conservative-type part))))))
(t
+ ;; Catch-all.
+ ;;
;; If the type contains some CONS types, the conservative type contains all
;; of them.
(when (types-equal-or-intersect type (specifier-type 'cons))
View
@@ -4341,3 +4341,19 @@
(cons (or (car x) (meh)))
(t (meh)))))))
(funcall (eh x)))) t t)))
+
+(with-test (:name (:bug-1050768 :symptom))
+ ;; Used to signal an error.
+ (compile nil
+ `(lambda (string position)
+ (char string position)
+ (array-in-bounds-p string (1+ position)))))
+
+(with-test (:name (:bug-1050768 :cause))
+ (let ((types `((string string)
+ ((or (simple-array character 24) (vector t 24))
+ (or (simple-array character 24) (vector t))))))
+ (dolist (pair types)
+ (destructuring-bind (orig conservative) pair
+ (assert sb-c::(type= (specifier-type cl-user::conservative)
+ (conservative-type (specifier-type cl-user::orig))))))))

0 comments on commit 7374cac

Please sign in to comment.