X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=083950175dad79781698008b176b5a2fb9ded55e;hb=7c406887c08477181e869b1b98142d99b52990ac;hp=2497c0689e253c720d54ff384136c24715620f1b;hpb=ca094620d68447584326dfaac532e7b2f1014d12;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 2497c06..0839501 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -87,6 +87,12 @@ (eq (defined-fun-inlinep fun) :notinline) (eq (info :function :inlinep name) :notinline)))) +;; This will get redefined in PCL boot. +(declaim (notinline update-info-for-gf)) +(defun maybe-update-info-for-gf (name) + (declare (ignorable name)) + (values)) + ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. (defun find-global-fun (name latep) @@ -110,61 +116,67 @@ (make-global-var :kind :global-function :%source-name name - :type (if (and (not latep) - (or *derive-function-types* - (eq where :declared) - (and (member name *fun-names-in-this-file* - :test #'equal) - (not (fun-lexically-notinline-p name))))) - (info :function :type 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))) -;;; 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 @@ -175,8 +187,9 @@ (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 @@ -1138,7 +1151,9 @@ (type-specifier old-type) (type-specifier type) var-name)))) - (bound-var (setf (leaf-type bound-var) int)) + (bound-var + (setf (leaf-type bound-var) int + (leaf-where-from bound-var) :declared)) (t (restr (cons var int))))))) (process-var var bound-var) @@ -1246,8 +1261,8 @@ (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)) @@ -1318,54 +1333,59 @@ (setf (lambda-var-ignorep var) t))))) (values)) -(defun process-dx-decl (names vars fvars) +(defun process-dx-decl (names vars fvars kind) (flet ((maybe-notify (control &rest args) (when (policy *lexenv* (> speed inhibit-warnings)) (apply #'compiler-notify control args)))) - (if (policy *lexenv* (= stack-allocate-dynamic-extent 3)) - (dolist (name names) - (cond - ((symbolp name) - (let* ((bound-var (find-in-bindings vars name)) - (var (or bound-var - (lexenv-find name vars) - (find-free-var name)))) - (etypecase var - (leaf - (if bound-var - (setf (leaf-dynamic-extent var) t) - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - name))) - (cons - (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) - (heap-alien-info - (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" - name))))) - ((and (consp name) - (eq (car name) 'function) - (null (cddr name)) - (valid-function-name-p (cadr name))) - (let* ((fname (cadr name)) - (bound-fun (find fname fvars - :key #'leaf-source-name - :test #'equal))) - (etypecase bound-fun - (leaf - #!+stack-allocatable-closures - (setf (leaf-dynamic-extent bound-fun) t) - #!-stack-allocatable-closures - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ + (let ((dx (cond ((eq 'truly-dynamic-extent kind) + :truly) + ((and (eq 'dynamic-extent kind) + *stack-allocate-dynamic-extent*) + t)))) + (if dx + (dolist (name names) + (cond + ((symbolp name) + (let* ((bound-var (find-in-bindings vars name)) + (var (or bound-var + (lexenv-find name vars) + (find-free-var name)))) + (etypecase var + (leaf + (if bound-var + (setf (leaf-dynamic-extent var) dx) + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + name))) + (cons + (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name)) + (heap-alien-info + (compiler-error "DYNAMIC-EXTENT on heap-alien-info: ~S" + name))))) + ((and (consp name) + (eq (car name) 'function) + (null (cddr name)) + (valid-function-name-p (cadr name))) + (let* ((fname (cadr name)) + (bound-fun (find fname fvars + :key #'leaf-source-name + :test #'equal))) + (etypecase bound-fun + (leaf + #!+stack-allocatable-closures + (setf (leaf-dynamic-extent bound-fun) dx) + #!-stack-allocatable-closures + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration on a function ~S ~ (not supported on this platform)." fname)) - (cons - (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) - (null - (maybe-notify - "ignoring DYNAMIC-EXTENT declaration for free ~S" - fname))))) - (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) - (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names)))) + (cons + (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname)) + (null + (maybe-notify + "ignoring DYNAMIC-EXTENT declaration for free ~S" + fname))))) + (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name)))) + (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))) ;;; FIXME: This is non-ANSI, so the default should be T, or it should ;;; go away, I think. @@ -1418,8 +1438,8 @@ (car types) `(values ,@types))))) res)) - (dynamic-extent - (process-dx-decl (cdr spec) vars fvars) + ((dynamic-extent truly-dynamic-extent) + (process-dx-decl (cdr spec) vars fvars (first spec)) res) ((disable-package-locks enable-package-locks) (make-lexenv