diff --git a/compiler/ir1final.lisp b/compiler/ir1final.lisp index 9dda94c72515ce9f28739b743efedb87dcbd721e..53f34c0355b1e0462522dc640b0c7a781298fedc 100644 --- a/compiler/ir1final.lisp +++ b/compiler/ir1final.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1final.lisp,v 1.9 1991/02/20 14:57:48 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1final.lisp,v 1.10 1991/03/11 17:14:09 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -19,7 +19,7 @@ (in-package 'c) -;;; Note-Failed-Optimization -- Interface +;;; Note-Failed-Optimization -- Internal ;;; ;;; Give the user grief about optimizations that we weren't able to do. It ;;; is assumed that they want to hear, or there wouldn't be any entries in the @@ -52,29 +52,72 @@ ~{~6T~?~^~&~}" (messages)))))))))) - -;;; Check-Free-Function -- Interface + +;;; Tail-Annotate -- Internal +;;; +;;; Mark all tail-recursive uses of function result continuations with the +;;; corresponding tail-set. Nodes whose type is NIL (i.e. don't return) such +;;; as calls to ERROR are never annotated as tail, so as to preserve debugging +;;; information. ;;; -;;; If the entry is a functional, then we update the global environment -;;; according to the new definition, checking for inconsistency. +(defun tail-annotate (component) + (declare (type component component)) + (dolist (fun (component-lambdas component)) + (let ((ret (lambda-return fun))) + (when ret + (let ((result (return-result ret)) + (tails (lambda-tail-set fun))) + (do-uses (use result) + (when (and (immediately-used-p result use) + (or (not (eq (node-derived-type use) *empty-type*)) + (not (basic-combination-p use)) + (eq (basic-combination-kind use) :local))) + (setf (node-tail-p use) tails))))))) + (undefined-value)) + + +;;; IR1-FINALIZE -- Interface ;;; -(proclaim '(function check-free-function (t leaf) void)) -(defun check-free-function (name leaf) - (etypecase leaf - (functional - (let* ((where (info function where-from name)) - (dtype (leaf-type leaf)) - (*compiler-error-context* (lambda-bind (main-entry leaf)))) - (note-name-defined name :function) - (ecase where - (:assumed - (let ((approx-type (info function assumed-type name))) - (when (and approx-type (function-type-p dtype)) - (valid-approximate-type approx-type dtype)) - (setf (info function type name) dtype) - (setf (info function assumed-type name) nil)) - (setf (info function where-from name) :defined)) - (:declared); No check for now, just keep declared type. - (:defined - (setf (info function type name) dtype))))) - (global-var))) +;;; 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 +;;; flow graph. +;;; -- 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 +;;; possibility that new references might be converted to it. +;;; -- Note any failed optimizations. +;;; +(defun ir1-finalize (component) + (declare (type component component)) + (tail-annotate component) + + (dolist (fun (component-lambdas component)) + (case (functional-kind fun) + (:external + (let* ((leaf (functional-entry-function fun)) + (name (leaf-name leaf)) + (where (info function where-from name)) + (dtype (definition-type leaf)) + (*compiler-error-context* (lambda-bind (main-entry leaf)))) + (setf (leaf-type leaf) dtype) + (when (eq leaf (gethash name *free-functions*)) + (note-name-defined name :function) + (remhash name *free-functions*) + (ecase where + (:assumed + (let ((approx-type (info function assumed-type name))) + (when (and approx-type (function-type-p dtype)) + (valid-approximate-type approx-type dtype)) + (setf (info function type name) dtype) + (setf (info function assumed-type name) nil)) + (setf (info function where-from name) :defined)) + (:declared); Just keep declared type. + (:defined + (setf (info function type name) dtype)))))) + ((nil) + (setf (leaf-type fun) (definition-type fun))))) + + (maphash #'note-failed-optimization *failed-optimizations*) + (clrhash *failed-optimizations*) + (undefined-value))