This is probably the same bug as 162
-235: "type system and inline expansion"
- a.
- (declaim (ftype (function (cons) number) acc))
- (declaim (inline acc))
- (defun acc (c)
- (the number (car c)))
-
- (defun foo (x y)
- (values (locally (declare (optimize (safety 0)))
- (acc x))
- (locally (declare (optimize (safety 3)))
- (acc y))))
-
- (foo '(nil) '(t)) => NIL, T.
-
- As of 0.9.15.41 this seems to be due to ACC being inlined only once
- inside FOO, which results in the second call reusing the FUNCTIONAL
- resulting from the first -- which doesn't check the type.
-
237: "Environment arguments to type functions"
a. Functions SUBTYPEP, TYPEP, UPGRADED-ARRAY-ELEMENT-TYPE, and
UPGRADED-COMPLEX-PART-TYPE now have an optional environment
computes the right offset for the memory copy.
* bug fix: compilation problem involving inlined calls to aliens with
result type VOID. (reported by Ken Olum)
+ * bug fix: #235a; sequential inline expasion in different policies no
+ longer reuses the functional from the previous expansion site.
changes in sbcl-1.0.24 relative to 1.0.23:
* new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data
leaf
inlinep
(info :function :info name))))
- ;; allow backward references to this function from
- ;; following top level forms
- (setf (defined-fun-functional leaf) res)
+ ;; Allow backward references to this function from following
+ ;; forms. (Reused only if policy matches.)
+ (push res (defined-fun-functionals leaf))
(change-ref-leaf ref res))))
(let ((fun (defined-fun-functional leaf)))
(if (or (not fun)
(with-ir1-environment-from-node call
(frob)
(locall-analyze-component *current-component*)))
- ;; If we've already converted, change ref to the converted functional.
+ ;; If we've already converted, change ref to the converted
+ ;; functional.
(change-ref-leaf ref fun))))
(values (ref-leaf ref) nil))
(t
:maybe-add-debug-catch t
:source-name name)))
(assert-global-function-definition-type name res)
- (setf (defined-fun-functional defined-fun-res) res)
+ (push res (defined-fun-functionals defined-fun-res))
(unless (eq (defined-fun-inlinep defined-fun-res) :notinline)
(substitute-leaf-if
(lambda (ref)
(setf (gethash name *free-funs*) res)))
;; If *FREE-FUNS* has a previously converted definition
;; for this name, then blow it away and try again.
- ((defined-fun-functional found)
+ ((defined-fun-functionals found)
(remhash name *free-funs*)
(get-defined-fun name))
(t found))))
*universal-type*)
:where-from where)))
-;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
+;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid?
+;;; Drop 'em.
;;;
-;;; In CMU CL, the answer was implicitly always true, so this
-;;; predicate didn't exist.
-;;;
-;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
-;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
-;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
-;;; "dead") component. When this IR1 stuff was reused in a new
-;;; component, under further obscure circumstances it could be used by
+;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS*
+;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object
+;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled
+;;; (aka "dead") component. When this IR1 stuff was reused in a new component,
+;;; under further obscure circumstances it could be used by
;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for
-;;; *CURRENT-COMPONENT*. At that point things got all confused, since
-;;; IR1 conversion was sending code to a component which had already
-;;; been compiled and would never be compiled again.
-(defun invalid-free-fun-p (free-fun)
+;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1
+;;; conversion was sending code to a component which had already been compiled
+;;; and would never be compiled again.
+;;;
+;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original
+;;; BUGS entry also makes it seem like this might not be an issue at all on
+;;; target.
+(defun clear-invalid-functionals (free-fun)
;; There might be other reasons that *FREE-FUN* entries could
;; become invalid, but the only one we've been bitten by so far
;; (sbcl-0.pre7.118) is this one:
- (and (defined-fun-p free-fun)
- (let ((functional (defined-fun-functional free-fun)))
- (or (and functional
- (eql (functional-kind functional) :deleted))
- (and (lambda-p functional)
- (or
- ;; (The main reason for this first test is to bail
- ;; out early in cases where the LAMBDA-COMPONENT
- ;; call in the second test would fail because links
- ;; it needs are uninitialized or invalid.)
- ;;
- ;; If the BIND node for this LAMBDA is null, then
- ;; according to the slot comments, the LAMBDA has
- ;; been deleted or its call has been deleted. In
- ;; that case, it seems rather questionable to reuse
- ;; it, and certainly it shouldn't be necessary to
- ;; reuse it, so we cheerfully declare it invalid.
- (null (lambda-bind functional))
- ;; If this IR1 stuff belongs to a dead component,
- ;; then we can't reuse it without getting into
- ;; bizarre confusion.
- (eql (component-info (lambda-component functional))
- :dead)))))))
+ (when (defined-fun-p free-fun)
+ (setf (defined-fun-functionals free-fun)
+ (delete-if (lambda (functional)
+ (or (eq (functional-kind functional) :deleted)
+ (when (lambda-p functional)
+ (or
+ ;; (The main reason for this first test is to bail
+ ;; out early in cases where the LAMBDA-COMPONENT
+ ;; call in the second test would fail because links
+ ;; it needs are uninitialized or invalid.)
+ ;;
+ ;; If the BIND node for this LAMBDA is null, then
+ ;; according to the slot comments, the LAMBDA has
+ ;; been deleted or its call has been deleted. In
+ ;; that case, it seems rather questionable to reuse
+ ;; it, and certainly it shouldn't be necessary to
+ ;; reuse it, so we cheerfully declare it invalid.
+ (not (lambda-bind functional))
+ ;; If this IR1 stuff belongs to a dead component,
+ ;; then we can't reuse it without getting into
+ ;; bizarre confusion.
+ (eq (component-info (lambda-component functional))
+ :dead)))))
+ (defined-fun-functionals free-fun)))
+ nil))
;;; If NAME already has a valid entry in *FREE-FUNS*, then return
;;; the value. Otherwise, make a new GLOBAL-VAR using information from
(declaim (ftype (sfunction (t string) global-var) find-free-fun))
(defun find-free-fun (name context)
(or (let ((old-free-fun (gethash name *free-funs*)))
- (and (not (invalid-free-fun-p old-free-fun))
- old-free-fun))
+ (when old-free-fun
+ (clear-invalid-functionals old-free-fun)
+ old-free-fun))
(ecase (info :function :kind name)
;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
(:macro
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
(defined-fun-inline-expansion var))
- (setf (defined-fun-functional res)
- (defined-fun-functional var)))
+ (setf (defined-fun-functionals res)
+ (defined-fun-functionals var)))
;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
;; to the original global-var?
res))
(eq (defined-fun-functional defined-fun) fun))
(remhash name *free-funs*))))))
+;;; Return functional for DEFINED-FUN which has been converted in policy
+;;; corresponding to the current one, or NIL if no such functional exists.
+(defun defined-fun-functional (defined-fun)
+ (let ((policy (lexenv-%policy *lexenv*)))
+ (dolist (functional (defined-fun-functionals defined-fun))
+ (when (equal policy (lexenv-%policy (functional-lexenv functional)))
+ (return functional)))))
+
;;; Do stuff to delete the semantic attachments of a REF node. When
;;; this leaves zero or one reference, we do a type dispatch off of
;;; the leaf to determine if a special action is appropriate.
;; global environment.
(inlinep nil :type inlinep)
(inline-expansion nil :type (or cons null))
- ;; the block-local definition of this function (either because it
- ;; was semi-inline, or because it was defined in this block). If
- ;; this function is not an entry point, then this may be deleted or
- ;; LET-converted. Null if we haven't converted the expansion yet.
- (functional nil :type (or functional null)))
+ ;; List of functionals corresponding to this DEFINED-FUN: either from the
+ ;; conversion of a NAMED-LAMBDA, or from inline-expansion (see
+ ;; RECOGNIZE-KNOWN-CALL) - we need separate functionals for each policy in
+ ;; which the function is used.
+ (functionals nil :type list))
(defprinter (defined-fun :identity t)
%source-name
#!+sb-show id
inlinep
- (functional :test functional))
+ (functionals :test functionals))
\f
;;;; function stuff
(%source-name (missing-arg) :type symbol :read-only t))
(defprinter (ref :identity t)
#!+sb-show id
- %source-name
+ (%source-name :test (neq %source-name '.anonymous.))
leaf)
;;; Naturally, the IF node always appears at the end of a block.
(declaim (type policy *policy*))
(defvar *policy*) ; initialized in cold init
+(defun sort-policy (policy)
+ ;; We occasionally want to compare policies using EQL, hence we
+ ;; canonize the order.
+ (sort policy #'string< :key #'car))
+
;;; This is to be called early in cold init to set things up, and may
;;; also be called again later in cold init in order to reset default
;;; optimization policy back to default values after toplevel PROCLAIM
;; Perhaps INHIBIT-NOTES?
inhibit-warnings))
(setf *policy*
- (mapcar (lambda (name)
- ;; CMU CL didn't use 1 as the default for
- ;; everything, but since ANSI says 1 is the ordinary
- ;; value, we do.
- (cons name 1))
- *policy-qualities*))
+ (sort-policy (mapcar (lambda (name)
+ ;; CMU CL didn't use 1 as the default for
+ ;; everything, but since ANSI says 1 is the ordinary
+ ;; value, we do.
+ (cons name 1))
+ *policy-qualities*)))
(setf *policy-restrictions* nil)
;; not actually POLICY, but very similar
(setf *handled-conditions* nil
(unless (assq (car old-entry) result)
(push old-entry result)))
;; Voila.
- result))
+ (sort-policy result)))
(declaim (ftype (function (list list) list)
process-handle-conditions-decl))
(process-package-lock-decl form *disabled-package-locks*)))
((inline notinline maybe-inline)
(dolist (name args)
- (proclaim-as-fun-name name) ; since implicitly it is a function
+ ; since implicitly it is a function, also scrubs *FREE-FUNS*
+ (proclaim-as-fun-name name)
(setf (info :function :inlinep name)
(ecase kind
(inline :inline)
(flet ((i (x) (frob x (bug-405-foo-bar foo))))
(i :five))))))
+;;; bug 235a
+(declaim (ftype (function (cons) number) bug-235a-aux))
+(declaim (inline bug-235a-aux))
+(defun bug-235a-aux (c)
+ (the number (car c)))
+(with-test (:name :bug-235a)
+ (let ((fun (compile nil
+ `(lambda (x y)
+ (values (locally (declare (optimize (safety 0)))
+ (bug-235a-aux x))
+ (locally (declare (optimize (safety 3)))
+ (bug-235a-aux y)))))))
+ (assert
+ (eq :error
+ (handler-case
+ (funcall fun '(:one) '(:two))
+ (type-error (e)
+ (assert (eq :two (type-error-datum e)))
+ (assert (eq 'number (type-error-expected-type e)))
+ :error))))))
\f
;;;; tests not in the problem domain, but of the consistency of the
;;;; compiler machinery itself
;;; 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.24.41"
+"1.0.24.42"
projects / sbcl.git / commitdiff