From 12836ca105af62252aa0974c3f6992e60ce0ebf4 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 14 Oct 2010 16:32:51 +0000 Subject: [PATCH] 1.0.43.57: better handling of derived function types 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. --- NEWS | 6 ++ src/compiler/ctype.lisp | 22 +++++-- src/compiler/ir1opt.lisp | 133 ++++++++++++++++++++------------------ src/compiler/ir1tran-lambda.lisp | 5 +- src/compiler/ir1tran.lisp | 56 +++++++++------- src/compiler/node.lisp | 16 ++--- src/pcl/methods.lisp | 17 ++--- tests/compiler.impure.lisp | 66 ++++++++++++++++--- tests/compiler.test.sh | 7 +- version.lisp-expr | 2 +- 10 files changed, 207 insertions(+), 123 deletions(-) diff --git a/NEWS b/NEWS index 4215598..c155052 100644 --- a/NEWS +++ b/NEWS @@ -11,6 +11,9 @@ changes relative to sbcl-1.0.43: * 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 @@ -59,6 +62,9 @@ changes relative to sbcl-1.0.43: * 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 diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 23cc3ce..8e1940b 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -837,13 +837,27 @@ ;;; 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)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 96fb563..961d1c4 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -322,8 +322,8 @@ (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)))) ;;;; IR1-OPTIMIZE @@ -801,24 +801,35 @@ (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) @@ -1041,50 +1052,46 @@ ;;; 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 @@ -1106,7 +1113,9 @@ (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)) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 93e739e..100c895 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -1115,7 +1115,7 @@ :%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 @@ -1240,8 +1240,7 @@ ;; 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 diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index d347bea..690d2a0 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -88,10 +88,16 @@ (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. @@ -113,24 +119,23 @@ ;; 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. @@ -210,7 +215,9 @@ :%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) @@ -1076,9 +1083,8 @@ (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))) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 5229904..5300228 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -619,16 +619,13 @@ ;; 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 @@ -695,6 +692,7 @@ %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) @@ -1233,6 +1231,8 @@ (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)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 2d63c9b..e9365a8 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -616,11 +616,11 @@ ;; 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) @@ -644,10 +644,11 @@ `(&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))))))) (defun compute-applicable-methods-function (generic-function arguments) (values (compute-applicable-methods-using-types diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index d8fcd3d..1e747c4 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -2003,27 +2003,77 @@ (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 diff --git a/tests/compiler.test.sh b/tests/compiler.test.sh index 549141d..0230c0c 100644 --- a/tests/compiler.test.sh +++ b/tests/compiler.test.sh @@ -26,14 +26,13 @@ cat > $tmpfilename < $tmpfilename <