1.0.12.3: less weakening of type-checks

* WEAKEN-TYPE used to return T for any union-type.  Instead, handle
  union-types implemented by backend properly.

* Also, if no supertype is found, don't replaces with T, as
  eg. oddball union types weakened to T can easily lead to heap
  corruption if the unchecked object ends up being trusted by the
  compiler. (See: WEAKEN-UNION-2 in type.impure.lisp.)

diff --git a/NEWS b/NEWS
index e5cba14..739621b 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
 changes in sbcl-1.0.13 relative to sbcl-1.0.12:
+  * bug fix: too liberal weakening of union-type checks when SPEED >
+    SAFETY.
   * bug fix: more bogus fixnum declarations in ROOM implementation
     have been fixed.
 

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index c70fb35..6274c30 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -87,12 +87,14 @@
         (min-type type)
         (found-super nil))
     (dolist (x *backend-type-predicates*)
-      (let ((stype (car x)))
-        (when (and (csubtypep type stype)
-                   (not (union-type-p stype)))
+      (let* ((stype (car x))
+             (samep (type= stype type)))
+        (when (or samep
+                  (and (csubtypep type stype)
+                       (not (union-type-p stype))))
           (let ((stype-cost (type-test-cost stype)))
             (when (or (< stype-cost min-cost)
-                      (type= stype type))
+                      samep)
               ;; If the supertype is equal in cost to the type, we
               ;; prefer the supertype. This produces a closer
               ;; approximation of the right thing in the presence of
@@ -100,9 +102,14 @@
               (setq found-super t
                     min-type stype
                     min-cost stype-cost))))))
+    ;; This used to return the *UNIVERSAL-TYPE* if no supertype was found,
+    ;; but that's too liberal: it's far too easy for the user to create
+    ;; a union type (which are excluded above), and then trick the compiler
+    ;; into trusting the union type... and finally ending up corrupting the
+    ;; heap once a bad object sneaks past the missing type check.
     (if found-super
         min-type
-        *universal-type*)))
+        type)))
 
 (defun weaken-values-type (type)
   (declare (type ctype type))

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 8ab2a97..e1e0b73 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -558,4 +558,27 @@
              (not sb-eval:interpreted-function))
            nil))
 
+;;; weakening of union type checks
+(defun weaken-union-1 (x)
+  (declare (optimize speed))
+  (car x))
+(multiple-value-bind (res err)
+    (ignore-errors (weaken-union-1 "askdjhasdkj"))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+(defun weaken-union-2 (x)
+  (declare (optimize speed)
+           (type (or cons fixnum) x))
+  (etypecase x
+    (fixnum x)
+    (cons
+     (setf (car x) 3)
+     x)))
+(multiple-value-bind (res err)
+    (ignore-errors (weaken-union-2 "asdkahsdkhj"))
+  (assert (not res))
+  (assert (typep err 'type-error))
+  (assert (or (equal '(or cons fixnum) (type-error-expected-type err))
+              (equal '(or fixnum cons) (type-error-expected-type err)))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 888b292..ea5377c 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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.12.2"
+"1.0.12.3"