X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1final.lisp;h=7fa816eb6827c32c4c59b9df2ae6a09911983f76;hb=6a9bbe6f36179cee92001a1f9ed5ff38be512644;hp=bdf3bca84f0092a563f20530444ede25a05f0b67;hpb=11214915e9b3151ec66dc3e30e1aa7638c676428;p=sbcl.git diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index bdf3bca..7fa816e 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 (eq :known (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 @@ -53,21 +53,22 @@ ;;; 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 +;;; 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-fun fun)) (defined-ftype (definition-type leaf))) (setf (leaf-type leaf) defined-ftype) - (when (leaf-has-source-name-p leaf) + (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-functions*)) + (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-functions*)) + (remhash source-name *free-funs*)) (ecase where (:assumed (let ((approx-type (info :function :assumed-type source-name))) @@ -80,13 +81,19 @@ (let ((declared-ftype (info :function :type source-name))) (unless (defined-ftype-matches-declared-ftype-p defined-ftype declared-ftype) - (note-lossage "~@" - (type-specifier declared-ftype) - (type-specifier defined-ftype))))) + (compiler-style-warn + "~@" + (type-specifier declared-ftype) + (type-specifier defined-ftype))))) (:defined - (when global-p - (setf (info :function :type source-name) defined-ftype)))))))) + (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 @@ -101,13 +108,34 @@ (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)))) + (let ((dest (node-dest ref))) (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))))) + (eq (lvar-uses (basic-combination-fun dest)) ref)) + (setq atype (note-fun-use dest atype))))) (setf (info :function :assumed-type name) atype)))) +;;; Merge CASTs with preceding/following nodes. +(defun ir1-merge-casts (component) + (do-blocks-backwards (block component) + (do-nodes-backwards (node lvar block) + (let ((dest (when lvar (lvar-dest lvar)))) + (cond ((and (cast-p dest) + (not (cast-type-check dest)) + (immediately-used-p lvar node)) + (when (values-types-equal-or-intersect + (node-derived-type node) + (cast-asserted-type dest)) + ;; FIXME: We do not perform pathwise CAST->type-error + ;; conversion, and type errors can later cause + ;; backend failures. On the other hand, this version + ;; produces less efficient code. + (derive-node-type node (cast-asserted-type dest)))) + ((and (cast-p node) + (eq (cast-type-check node) :external)) + (aver (basic-combination-p dest)) + (delete-filter node lvar (cast-value node)))))))) + ;;; Do miscellaneous things that we want to do once all optimization ;;; has been done: ;;; -- Record the derived result type before the back-end trashes the @@ -126,7 +154,10 @@ (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*) + + (ir1-merge-casts component) + (values))