Fixes bug 657499, and improves the earlier fix of 655126.
* Sort out TYPE vs. DEFINED-TYPE in FIND-GLOBAL-FUN:
** TYPE is the declarared type, OR the derived type iff
*derive-function-types* is true, no ftype has been declared,
we're not explicitly late-binding, and the function is not
NOTINLINE.
** DEFINED-TYPE is the derived type, or FUNCTION if the function has
been declared NOTINLINE or we're late-binding.
Previously TYPE (which is what the rest of the system trusts
implcitly) was the derived type for functions in the same file
not declared NOTINLINE.
* ASSERT-CALL-TYPE can now be used in "untrusted" cases as well:
argument types are asserted as before, but instead of using
DERIVE-NODE-TYPE to annotate the function LVAR with its type, we
instead assert the return-type when appropriate.
* VALIDATE-CALL-TYPE is now called with DEFINED-TYPE from
IR1-OPTIMIZE-COMBINATION, not
IR1-CONVERT-COMBINATION-CHECKING-TYPE: the DEFINED-TYPE may be used
there in an untrusted call to ASSERT-CALL-TYPE.
Also keep track of the leaves whose DEFINED-TYPE we have asserted,
so that we won't do duplicate work. New slot in COMBINATION:
TYPE-VALIDATED-FOR-LEAF is utilized for this.
* LEAF-WHERE-FROM can now also be :DEFINED-HERE, meaning the
definition originates in the file being compiled -- this
information is used by VALIDATE-CALL-TYPE, and filled in by
FIND-FREE-FUN and FIND-GLOBAL-FUN.
* Adjust the tests for 655126 to account for full warnings
in case *derive-function-types* and self-calls.
* enhancement: ATOMIC-INCF now supports AREF of (SIMPLE-ARRAY SB-EXT:WORD (*))
as a place.
* enhancement: ASDF has been updated to 2.009.
+ * enhancement: the system detects known type-erros in calls better,
+ signalling a full warning about violated proclaimed FTYPEs and violations
+ of derived FTYPEs within the same file, including self-calls.
* optimization: constant-folding exploits numeric and character types, in
addition member types.
* optimization: numeric, character and member types that are inhabited by
* bug fix: incorrect FILE-POSITION on streams opened using :EXTERNAL-FORMAT
:DEFAULT when the default external had character size other than 8 bits.
(lp#657183)
+ * bug fix: derived types of functions in the same file were implicitly
+ trusted, leading to potential heap corruption when those function were
+ defined incompatibly. (lp#657499)
changes in sbcl-1.0.43 relative to sbcl-1.0.42:
* incompatible change: FD-STREAMS no longer participate in the serve-event
;;; Assert that CALL is to a function of the specified TYPE. It is
;;; assumed that the call is legal and has only constants in the
;;; keyword positions.
-(defun assert-call-type (call type)
+(defun assert-call-type (call type &optional (trusted t))
(declare (type combination call) (type fun-type type))
- (derive-node-type call (fun-type-returns type))
- (let ((policy (lexenv-policy (node-lexenv call))))
+ (let ((policy (lexenv-policy (node-lexenv call)))
+ (returns (fun-type-returns type)))
+ (if trusted
+ (derive-node-type call returns)
+ (let ((lvar (node-lvar call)))
+ ;; If the value is used in a non-tail position, and
+ ;; the lvar is a single-use, assert the type. Multiple use
+ ;; sites need to be elided because the assertion has to apply
+ ;; to all uses. Tail positions are elided because the assertion
+ ;; would lose cause us not the be in a tail-position anymore.
+ (when (and lvar
+ (not (return-p (lvar-dest lvar)))
+ (lvar-has-single-use-p lvar))
+ (when (assert-lvar-type lvar returns policy)
+ (reoptimize-lvar lvar)))))
(map-combination-args-and-types
(lambda (arg type)
- (assert-lvar-type arg type policy))
+ (when (assert-lvar-type arg type policy)
+ (unless trusted (reoptimize-lvar arg))))
call))
(values))
\f
(dest (lvar-dest lvar)))
(substitute-lvar internal-lvar lvar)
(let ((cast (insert-cast-before dest lvar type policy)))
- (use-lvar cast internal-lvar))))
- (values))
+ (use-lvar cast internal-lvar)
+ t))))
\f
;;;; IR1-OPTIMIZE
(dolist (arg args)
(when arg
(setf (lvar-reoptimize arg) nil)))
- (when info
- (check-important-result node info)
- (let ((fun (fun-info-destroyed-constant-args info)))
- (when fun
- (let ((destroyed-constant-args (funcall fun args)))
- (when destroyed-constant-args
- (let ((*compiler-error-context* node))
- (warn 'constant-modified
- :fun-name (lvar-fun-name
- (basic-combination-fun node)))
- (setf (basic-combination-kind node) :error)
- (return-from ir1-optimize-combination))))))
- (let ((fun (fun-info-derive-type info)))
- (when fun
- (let ((res (funcall fun node)))
- (when res
- (derive-node-type node (coerce-to-values res))
- (maybe-terminate-block node nil)))))))
+ (cond (info
+ (check-important-result node info)
+ (let ((fun (fun-info-destroyed-constant-args info)))
+ (when fun
+ (let ((destroyed-constant-args (funcall fun args)))
+ (when destroyed-constant-args
+ (let ((*compiler-error-context* node))
+ (warn 'constant-modified
+ :fun-name (lvar-fun-name
+ (basic-combination-fun node)))
+ (setf (basic-combination-kind node) :error)
+ (return-from ir1-optimize-combination))))))
+ (let ((fun (fun-info-derive-type info)))
+ (when fun
+ (let ((res (funcall fun node)))
+ (when res
+ (derive-node-type node (coerce-to-values res))
+ (maybe-terminate-block node nil))))))
+ (t
+ ;; Check against the DEFINED-TYPE unless TYPE is already good.
+ (let* ((fun (basic-combination-fun node))
+ (uses (lvar-uses fun))
+ (leaf (when (ref-p uses) (ref-leaf uses))))
+ (multiple-value-bind (type defined-type)
+ (if (global-var-p leaf)
+ (values (leaf-type leaf) (leaf-defined-type leaf))
+ (values nil nil))
+ (when (and (not (fun-type-p type)) (fun-type-p defined-type))
+ (validate-call-type node type leaf)))))))
(:known
(aver info)
(dolist (arg args)
;;; syntax check, arg/result type processing, but still call
;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
;;; and that checking is done by local call analysis.
-(defun validate-call-type (call type defined-type ir1-converting-not-optimizing-p)
+(defun validate-call-type (call type fun &optional ir1-converting-not-optimizing-p)
(declare (type combination call) (type ctype type))
- (cond ((not (fun-type-p type))
- (aver (multiple-value-bind (val win)
- (csubtypep type (specifier-type 'function))
- (or val (not win))))
- ;; In the commonish case where the function has been defined
- ;; in another file, we only get FUNCTION for the type; but we
- ;; can check whether the current call is valid for the
- ;; existing definition, even if only to STYLE-WARN about it.
- (when defined-type
- (valid-fun-use call defined-type
+ (let* ((where (when fun (leaf-where-from fun)))
+ (same-file-p (eq :defined-here where)))
+ (cond ((not (fun-type-p type))
+ (aver (multiple-value-bind (val win)
+ (csubtypep type (specifier-type 'function))
+ (or val (not win))))
+ ;; Using the defined-type too early is a bit of a waste: during
+ ;; conversion we cannot use the untrusted ASSERT-CALL-TYPE, etc.
+ (when (and fun (not ir1-converting-not-optimizing-p))
+ (let ((defined-type (leaf-defined-type fun)))
+ (when (and (fun-type-p defined-type)
+ (neq fun (combination-type-validated-for-leaf call)))
+ ;; Don't validate multiple times against the same leaf --
+ ;; it doesn't add any information, but may generate the same warning
+ ;; multiple times.
+ (setf (combination-type-validated-for-leaf call) fun)
+ (when (and (valid-fun-use call defined-type
+ :argument-test #'always-subtypep
+ :result-test nil
+ :lossage-fun (if same-file-p
+ #'compiler-warn
+ #'compiler-style-warn)
+ :unwinnage-fun #'compiler-notify)
+ same-file-p)
+ (assert-call-type call defined-type nil)
+ (maybe-terminate-block call ir1-converting-not-optimizing-p)))))
+ (recognize-known-call call ir1-converting-not-optimizing-p))
+ ((valid-fun-use call type
:argument-test #'always-subtypep
:result-test nil
- :lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-notify))
- (recognize-known-call call ir1-converting-not-optimizing-p))
- ((valid-fun-use call type
- :argument-test #'always-subtypep
- :result-test nil
- ;; KLUDGE: Common Lisp is such a dynamic
- ;; language that all we can do here in
- ;; general is issue a STYLE-WARNING. It
- ;; would be nice to issue a full WARNING
- ;; in the special case of of type
- ;; mismatches within a compilation unit
- ;; (as in section 3.2.2.3 of the spec)
- ;; but at least as of sbcl-0.6.11, we
- ;; don't keep track of whether the
- ;; mismatched data came from the same
- ;; compilation unit, so we can't do that.
- ;; -- WHN 2001-02-11
- ;;
- ;; FIXME: Actually, I think we could
- ;; issue a full WARNING if the call
- ;; violates a DECLAIM FTYPE.
- :lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-notify)
- (assert-call-type call type)
- (maybe-terminate-block call ir1-converting-not-optimizing-p)
- (recognize-known-call call ir1-converting-not-optimizing-p))
- (t
- (setf (combination-kind call) :error)
- (values nil nil))))
+ :lossage-fun #'compiler-warn
+ :unwinnage-fun #'compiler-notify)
+ (assert-call-type call type)
+ (maybe-terminate-block call ir1-converting-not-optimizing-p)
+ (recognize-known-call call ir1-converting-not-optimizing-p))
+ (t
+ (setf (combination-kind call) :error)
+ (values nil nil)))))
;;; This is called by IR1-OPTIMIZE when the function for a call has
;;; changed. If the call is local, we try to LET-convert it, and
(derive-node-type call (tail-set-type (lambda-tail-set fun))))))
(:full
(multiple-value-bind (leaf info)
- (validate-call-type call (lvar-type fun-lvar) nil nil)
+ (let* ((uses (lvar-uses fun-lvar))
+ (leaf (when (ref-p uses) (ref-leaf uses))))
+ (validate-call-type call (lvar-type fun-lvar) leaf))
(cond ((functional-p leaf)
(convert-call-if-possible
(lvar-uses (basic-combination-fun call))
:%source-name name
:where-from (if (eq where-from :declared)
:declared
- :defined)
+ :defined-here)
:type (if (eq :declared where-from)
(leaf-type found)
(if lp
;; old CMU CL comment:
;; If there is a type from a previous definition, blast it,
;; since it is obsolete.
- (when (and defined-fun
- (eq (leaf-where-from defined-fun) :defined))
+ (when (and defined-fun (neq :declared (leaf-where-from defined-fun)))
(setf (leaf-type defined-fun)
;; FIXME: If this is a block compilation thing, shouldn't
;; we be setting the type to the full derived type for the
(eq (info :function :inlinep name) :notinline))))
;; This will get redefined in PCL boot.
-(declaim (notinline update-info-for-gf))
+(declaim (notinline maybe-update-info-for-gf))
(defun maybe-update-info-for-gf (name)
- (declare (ignorable name))
- (values))
+ (declare (ignore name))
+ nil)
+
+(defun maybe-defined-here (name where)
+ (if (and (eq :defined where)
+ (member name *fun-names-in-this-file* :test #'equal))
+ :defined-here
+ where))
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
;; complain about undefined functions.
(not latep))
(note-undefined-reference name :function))
- (make-global-var
- :kind :global-function
- :%source-name name
- :type (if (or (eq where :declared)
- (and (not latep)
- (or *derive-function-types*
- (eq where :defined-method)
- (and (not (fun-lexically-notinline-p name))
- (member name *fun-names-in-this-file*
- :test #'equal)))))
- (progn
- (maybe-update-info-for-gf name)
- (info :function :type name))
- (specifier-type 'function))
- :defined-type (if (eq where :defined)
- (info :function :type name)
- *universal-type*)
- :where-from where)))
+ (let ((ftype (info :function :type name))
+ (notinline (fun-lexically-notinline-p name)))
+ (make-global-var
+ :kind :global-function
+ :%source-name name
+ :type (if (or (eq where :declared)
+ (and (not latep)
+ (not notinline)
+ *derive-function-types*))
+ ftype
+ (specifier-type 'function))
+ :defined-type (if (and (not latep) (not notinline))
+ (or (maybe-update-info-for-gf name) ftype)
+ (specifier-type 'function))
+ :where-from (if notinline
+ where
+ (maybe-defined-here name where))))))
;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid?
;;; Drop 'em.
:%source-name name
:inline-expansion expansion
:inlinep inlinep
- :where-from where
+ :where-from (if (eq inlinep :notinline)
+ where
+ (maybe-defined-here name where))
:type (if (and (eq inlinep :notinline)
(neq where :declared))
(specifier-type 'function)
(type leaf var))
(let* ((node (ir1-convert-combination start next result form var))
(fun-lvar (basic-combination-fun node))
- (type (leaf-type var))
- (defined-type (leaf-defined-type var)))
- (when (validate-call-type node type defined-type t)
+ (type (leaf-type var)))
+ (when (validate-call-type node type var t)
(setf (lvar-%derived-type fun-lvar)
(make-single-value-type type))
(setf (lvar-reoptimize fun-lvar) nil)))
;; the type which values of this leaf have last been defined to have
;; (but maybe won't have in future, in case of redefinition)
(defined-type *universal-type* :type ctype)
- ;; where the TYPE information came from:
+ ;; where the TYPE information came from (in order, from strongest to weakest):
;; :DECLARED, from a declaration.
- ;; :ASSUMED, from uses of the object.
- ;; :DEFINED, from examination of the definition.
+ ;; :DEFINED-HERE, from examination of the definition in the same file.
+ ;; :DEFINED, from examination of the definition elsewhere.
;; :DEFINED-METHOD, implicit, piecemeal declarations from CLOS.
- ;; FIXME: This should be a named type. (LEAF-WHERE-FROM? Or
- ;; perhaps just WHERE-FROM, since it's not just used in LEAF,
- ;; but also in various DEFINE-INFO-TYPEs in globaldb.lisp,
- ;; and very likely elsewhere too.)
- (where-from :assumed :type (member :declared :assumed :defined :defined-method))
+ ;; :ASSUMED, from uses of the object.
+ (where-from :assumed :type (member :declared :assumed :defined-here :defined :defined-method))
;; list of the REF nodes for this leaf
(refs () :type list)
;; true if there was ever a REF or SET node for this leaf. This may
%source-name
#!+sb-show id
(type :test (not (eq type *universal-type*)))
+ (defined-type :test (not (eq defined-type *universal-type*)))
(where-from :test (not (eq where-from :assumed)))
kind)
(kind :full :type (member :local :full :error :known))
;; if a call to a known global function, contains the FUN-INFO.
(fun-info nil :type (or fun-info null))
+ ;; Untrusted type we have asserted for this combination.
+ (type-validated-for-leaf nil)
;; some kind of information attached to this node by the back end
(info nil)
(step-info))
;; 7.6.4 point 5 probably entails that if any method says
;; &allow-other-keys then the gf should be construed to
;; accept any key.
- (let ((allowp (or gf.allowp
- (find '&allow-other-keys methods
- :test #'find
- :key #'method-lambda-list))))
- (setf (info :function :type name)
+ (let* ((allowp (or gf.allowp
+ (find '&allow-other-keys methods
+ :test #'find
+ :key #'method-lambda-list)))
+ (ftype
(specifier-type
`(function
(,@(mapcar tfun gf.required)
`(&key))
,@(when allowp
`(&allow-other-keys)))
- *))
+ *))))
+ (setf (info :function :type name) ftype
(info :function :where-from name) :defined-method
- (gf-info-needs-update gf) nil))))))
- (values)))
+ (gf-info-needs-update gf) nil)
+ ftype)))))))
\f
(defun compute-applicable-methods-function (generic-function arguments)
(values (compute-applicable-methods-using-types
(length (clear-derived-types-on-set-fdefn-1)))))
(assert (= 6 (clear-derived-types-on-set-fdefn-2)))))
-(test-util:with-test (:name :bug-655126)
+(test-util:with-test (:name (:bug-655126 :derive-function-types t))
(let ((*evaluator-mode* :compile)
(*derive-function-types* t))
(eval `(defun bug-655126 (x) x))
- (assert (eq :style-warning
+ ;; Full warnings are ok due to *derive-function-types* = T.
+ (assert (eq :full-warning
(handler-case
(eval `(defun bug-655126-2 ()
(bug-655126)))
- (style-warning ()
- :style-warning))))
+ ((and warning (not style-warning)) ()
+ :full-warning))))
(assert (eq 'bug-655126
(handler-case
(eval `(defun bug-655126 (x y)
(cons x y)))
- ((and style-warning (not sb-kernel:redefinition-warning)) ()
+ ((and warning (not sb-kernel:redefinition-warning)) ()
:oops))))
- (assert (eq :style-warning
+ (assert (eq :full-warning
(handler-case
(eval `(defun bug-655126 (x)
(bug-655126 x y)))
- ((and style-warning (not sb-kernel:redefinition-warning)) ()
- :style-warning))))))
+ ((and warning
+ (not style-warning)
+ (not sb-kernel:redefinition-warning)) ()
+ :full-warning))))))
+
+(test-util:with-test (:name (:bug-655126 :derive-function-types nil))
+ (let ((*evaluator-mode* :compile))
+ (eval `(defun bug-655126/b (x) x))
+ ;; Just style-warning here.
+ (assert (eq :style-warning
+ (handler-case
+ (eval `(defun bug-655126-2/b ()
+ (bug-655126/b)))
+ (style-warning ()
+ :style-warning))))
+ (assert (eq 'bug-655126/b
+ (handler-case
+ (eval `(defun bug-655126/b (x y)
+ (cons x y)))
+ ((and warning (not sb-kernel:redefinition-warning)) ()
+ :oops))))
+ ;; Bogus self-call is always worth a full one.
+ (assert (eq :full-warning
+ (handler-case
+ (eval `(defun bug-655126/b (x)
+ (bug-655126/b x y)))
+ ((and warning
+ (not style-warning)
+ (not sb-kernel:redefinition-warning)) ()
+ :full-warning))))))
+
+(test-util:with-test (:name :bug-657499)
+ ;; Don't trust derived types within the compilation unit.
+ (ctu:file-compile
+ `((declaim (optimize safety))
+ (defun bug-657499-foo ()
+ (cons t t))
+ (defun bug-657499-bar ()
+ (let ((cons (bug-657499-foo)))
+ (setf (car cons) 3)
+ cons)))
+ :load t)
+ (locally (declare (optimize safety))
+ (setf (symbol-function 'bug-657499-foo) (constantly "foobar"))
+ (assert (eq :type-error
+ (handler-case
+ (funcall 'bug-657499-bar)
+ (type-error (e)
+ (assert (eq 'cons (type-error-expected-type e)))
+ (assert (equal "foobar" (type-error-datum e)))
+ :type-error))))))
;;; success
EOF
expect_failed_compile $tmpfilename
-# This should fail (but right now we just get a style-warning), as
-# type inference should show that the call to FOO has a wrong number
-# of args.
+# This should fail, as type inference should show that the call to FOO
+# has a wrong number of args.
cat > $tmpfilename <<EOF
(in-package :cl-user)
(defun foo (x) (or x (foo x x)))
EOF
-expect_condition_during_compile style-warning $tmpfilename
+expect_failed_compile $tmpfilename
# This should fail, as we define a function multiply in the same file
# (CLHS 3.2.2.3).
;;; 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.43.56"
+"1.0.43.57"
projects / sbcl.git / commitdiff