From 14115e1756e5764ef9e200f331912ae3a48cc4a2 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 26 Nov 2007 18:06:06 +0000 Subject: [PATCH 1/1] 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.) --- NEWS | 2 ++ src/compiler/checkgen.lisp | 17 ++++++++++++----- tests/type.impure.lisp | 23 +++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 38 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index e5cba14..739621b 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4