X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1final.lisp;h=a921fc8771c28f8e7d04731ef97c3a19c8ed0c10;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=7f2024631e1d6dcc4dd5d7121571ccbc49400907;hpb=d40a76606c86722b0aef8179155f9f2840739b72;p=sbcl.git diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index 7f20246..a921fc8 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -20,73 +20,74 @@ (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) - (collect ((messages)) - (flet ((give-grief (string &rest stuff) - (messages string) - (messages stuff))) - (valid-function-use node what - :unwinnage-fun #'give-grief - :lossage-fun #'give-grief)) - (compiler-note "~@" - 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 - ;; doesn't want to hear about it. The things I caught when - ;; I put ERROR "internal error: unexpected FAILURE=~S" here - ;; didn't look like things we need to report. -- WHN 2001-02-07 - )))))) + (let ((what (cdr failure)) + (note (transform-note (car failure)))) + (cond + ((consp what) + (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 ((give-grief (string &rest stuff) + (messages string) + (messages stuff))) + (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 + ;; doesn't want to hear about it. The things I caught when + ;; I put ERROR "internal error: unexpected FAILURE=~S" here + ;; didn't look like things we need to report. -- WHN 2001-02-07 + )))))) ;;; 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))) + (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-p (defined-fun-p global-def))) - (note-name-defined source-name :function) - (when global-p - (remhash source-name *free-functions*)) - (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) - (note-lossage "~@" - (type-specifier declared-ftype) - (type-specifier defined-ftype))))) - (:defined - (when global-p - (setf (info :function :type source-name) defined-ftype)))))))) + (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 :defined-method) + (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))))))) (values)) ;;; Find all calls in COMPONENT to assumed functions and update the @@ -95,19 +96,45 @@ ;;; types. (defun note-assumed-types (component name var) (when (and (eq (leaf-where-from var) :assumed) - (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)) + (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 (node-component ref) component) - (combination-p dest) - (eq (continuation-use (basic-combination-fun dest)) ref)) - (setq atype (note-fun-use dest atype))))) + (let ((dest (node-dest ref))) + (when (and (eq (node-component ref) component) + (combination-p dest) + (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)) + (let ((dtype (node-derived-type node)) + (atype (node-derived-type dest))) + (when (values-types-equal-or-intersect + dtype atype) + ;; 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. + ;; + ;; This is sorta DERIVE-NODE-TYPE, but does not try + ;; to optimize the node. + (setf (node-derived-type node) + (values-type-intersection dtype atype))))) + ((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 @@ -120,13 +147,16 @@ (case (functional-kind fun) (:external (finalize-xep-definition fun)) - ((nil) + ((nil :toplevel) (setf (leaf-type fun) (definition-type fun))))) (maphash #'note-failed-optimization - (component-failed-optimizations component)) + (component-failed-optimizations component)) (maphash (lambda (k v) - (note-assumed-types component k v)) - *free-functions*) + (note-assumed-types component k v)) + *free-funs*) + + (ir1-merge-casts component) + (values))