Skip to content
Snippets Groups Projects
Commit d2215ce4 authored by ram's avatar ram
Browse files

Added new IR1-FINALIZE function that combines a bunch of stuff previously

being done separately.
parent f5a4a950
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -19,7 +19,7 @@
(in-package 'c) (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 ;;; 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 ;;; is assumed that they want to hear, or there wouldn't be any entries in the
...@@ -52,29 +52,72 @@ ...@@ -52,29 +52,72 @@
~{~6T~?~^~&~}" ~{~6T~?~^~&~}"
(messages)))))))))) (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 (defun tail-annotate (component)
;;; according to the new definition, checking for inconsistency. (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)) ;;; Do miscellaneous things that we want to do once all optimization has
(defun check-free-function (name leaf) ;;; been done:
(etypecase leaf ;;; -- Record the derived result type before the back-end trashes the
(functional ;;; flow graph.
(let* ((where (info function where-from name)) ;;; -- For each named function with an XEP, note the definition of that name,
(dtype (leaf-type leaf)) ;;; and add derived type information to the info environment. We also
(*compiler-error-context* (lambda-bind (main-entry leaf)))) ;;; delete the FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the
(note-name-defined name :function) ;;; possibility that new references might be converted to it.
(ecase where ;;; -- Note any failed optimizations.
(:assumed ;;;
(let ((approx-type (info function assumed-type name))) (defun ir1-finalize (component)
(when (and approx-type (function-type-p dtype)) (declare (type component component))
(valid-approximate-type approx-type dtype)) (tail-annotate component)
(setf (info function type name) dtype)
(setf (info function assumed-type name) nil)) (dolist (fun (component-lambdas component))
(setf (info function where-from name) :defined)) (case (functional-kind fun)
(:declared); No check for now, just keep declared type. (:external
(:defined (let* ((leaf (functional-entry-function fun))
(setf (info function type name) dtype))))) (name (leaf-name leaf))
(global-var))) (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))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment