X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1final.lisp;h=3fa8bd38ba0ba97609897c3a067132ce931b0d32;hb=ff57884e206ac28660af6af34315bc9b81697f57;hp=c843505170a4c1d3b90433f6c778ee0df13c63a7;hpb=6c765578c8dc4bcc7798e37c9918715f198b30da;p=sbcl.git diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index c843505..3fa8bd3 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -20,29 +20,29 @@ (defun note-failed-optimization (node failures) (declare (type combination node) (list failures)) (unless (or (node-deleted node) - (not (function-info-p (combination-kind node)))) + (not (fun-info-p (combination-kind node)))) (let ((*compiler-error-context* node)) (dolist (failure failures) (let ((what (cdr failure)) (note (transform-note (car failure)))) (cond ((consp what) - (compiler-note "~@" - note (first what) (rest what))) - ((valid-function-use node what - :argument-test #'types-equal-or-intersect - :result-test #'values-types-equal-or-intersect) + (compiler-notify "~@" + note (first what) (rest what))) + ((valid-fun-use node what + :argument-test #'types-equal-or-intersect + :result-test #'values-types-equal-or-intersect) (collect ((messages)) - (flet ((frob (string &rest stuff) + (flet ((give-grief (string &rest stuff) (messages string) (messages stuff))) - (valid-function-use node what - :warning-function #'frob - :error-function #'frob)) - (compiler-note "~@" + (valid-fun-use node what + :unwinnage-fun #'give-grief + :lossage-fun #'give-grief)) + (compiler-notify "~@" note (messages)))) ;; As best I can guess, it's OK to fall off the end here ;; because if it's not a VALID-FUNCTION-USE, the user @@ -52,42 +52,48 @@ )))))) ;;; For each named function with an XEP, note the definition of that -;;; name, and add derived type information to the info environment. We -;;; also delete the FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the +;;; name, and add derived type information to the INFO environment. We +;;; also delete the FUNCTIONAL from *FREE-FUNS* to eliminate the ;;; possibility that new references might be converted to it. (defun finalize-xep-definition (fun) - (let* ((leaf (functional-entry-function fun)) - (name (leaf-name leaf)) + (let* ((leaf (functional-entry-fun fun)) (defined-ftype (definition-type leaf))) (setf (leaf-type leaf) defined-ftype) - (when (or (and name (symbolp name)) - (and (consp name) (eq (car name) 'setf))) - (let* ((where (info :function :where-from name)) - (*compiler-error-context* (lambda-bind (main-entry leaf))) - (global-def (gethash name *free-functions*)) - (global-p (defined-function-p global-def))) - (note-name-defined name :function) - (when global-p - (remhash name *free-functions*)) - (ecase where - (:assumed - (let ((approx-type (info :function :assumed-type name))) - (when (and approx-type (function-type-p defined-ftype)) - (valid-approximate-type approx-type defined-ftype)) - (setf (info :function :type name) defined-ftype) - (setf (info :function :assumed-type name) nil)) - (setf (info :function :where-from name) :defined)) - (:declared - (let ((declared-ftype (info :function :type name))) - (unless (defined-ftype-matches-declared-ftype-p - defined-ftype declared-ftype) - (note-lossage "~@" - (type-specifier declared-ftype) - (type-specifier defined-ftype))))) - (:defined - (when global-p - (setf (info :function :type name) defined-ftype))))))) + (when (and (leaf-has-source-name-p leaf) + (eq (leaf-source-name leaf) (functional-debug-name leaf))) + (let ((source-name (leaf-source-name leaf))) + (let* ((where (info :function :where-from source-name)) + (*compiler-error-context* (lambda-bind (main-entry leaf))) + (global-def (gethash source-name *free-funs*)) + (global-p (defined-fun-p global-def))) + (note-name-defined source-name :function) + (when global-p + (remhash source-name *free-funs*)) + (ecase where + (:assumed + (let ((approx-type (info :function :assumed-type source-name))) + (when (and approx-type (fun-type-p defined-ftype)) + (valid-approximate-type approx-type defined-ftype)) + (setf (info :function :type source-name) defined-ftype) + (setf (info :function :assumed-type source-name) nil)) + (setf (info :function :where-from source-name) :defined)) + (:declared + (let ((declared-ftype (info :function :type source-name))) + (unless (defined-ftype-matches-declared-ftype-p + defined-ftype declared-ftype) + (compiler-style-warn + "~@" + (type-specifier declared-ftype) + (type-specifier defined-ftype))))) + (:defined + (setf (info :function :type source-name) defined-ftype))) + (when (fasl-output-p *compile-object*) + (if (member source-name *fun-names-in-this-file* :test #'equal) + (compiler-warn "~@" + source-name) + (push source-name *fun-names-in-this-file*))))))) (values)) ;;; Find all calls in COMPONENT to assumed functions and update the @@ -96,17 +102,17 @@ ;;; types. (defun note-assumed-types (component name var) (when (and (eq (leaf-where-from var) :assumed) - (not (and (defined-function-p var) - (eq (defined-function-inlinep var) :notinline))) + (not (and (defined-fun-p var) + (eq (defined-fun-inlinep var) :notinline))) (eq (info :function :where-from name) :assumed) (eq (info :function :kind name) :function)) (let ((atype (info :function :assumed-type name))) (dolist (ref (leaf-refs var)) (let ((dest (continuation-dest (node-cont ref)))) - (when (and (eq (block-component (node-block ref)) component) + (when (and (eq (node-component ref) component) (combination-p dest) (eq (continuation-use (basic-combination-fun dest)) ref)) - (setq atype (note-function-use dest atype))))) + (setq atype (note-fun-use dest atype))))) (setf (info :function :assumed-type name) atype)))) ;;; Do miscellaneous things that we want to do once all optimization @@ -127,7 +133,7 @@ (maphash #'note-failed-optimization (component-failed-optimizations component)) - (maphash #'(lambda (k v) - (note-assumed-types component k v)) - *free-functions*) + (maphash (lambda (k v) + (note-assumed-types component k v)) + *free-funs*) (values))