/[cmucl]/src/compiler/ir1final.lisp
ViewVC logotype

Contents of /src/compiler/ir1final.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26 - (show annotations)
Tue Apr 20 17:57:46 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.25: +6 -6 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: C; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/compiler/ir1final.lisp,v 1.26 2010/04/20 17:57:46 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file implements the IR1 finalize phase, which checks for various
13 ;;; semantic errors.
14 ;;;
15 ;;; Written by Rob MacLachlan
16 ;;;
17 (in-package "C")
18 (intl:textdomain "cmucl")
19
20
21 ;;; Note-Failed-Optimization -- Internal
22 ;;;
23 ;;; Give the user grief about optimizations that we weren't able to do. It
24 ;;; is assumed that they want to hear, or there wouldn't be any entries in the
25 ;;; table. If the node has been deleted or is no longer a known call, then do
26 ;;; nothing; some other optimization must have gotten to it.
27 ;;;
28 (defun note-failed-optimization (node failures)
29 (declare (type combination node) (list failures))
30 (unless (or (node-deleted node)
31 (not (function-info-p (combination-kind node))))
32 (let ((*compiler-error-context* node))
33 (dolist (failure failures)
34 (let ((what (cdr failure))
35 (note (transform-note (car failure))))
36 (cond
37 ((consp what)
38 (efficiency-note (intl:gettext "Unable to ~A because:~%~6T~?")
39 note (first what) (rest what)))
40 ((valid-function-use node what
41 :argument-test #'types-intersect
42 :result-test #'values-types-intersect)
43 (collect ((messages))
44 (flet ((frob (string &rest stuff)
45 (messages string)
46 (messages stuff)))
47 (valid-function-use node what
48 :warning-function #'frob
49 :error-function #'frob))
50
51 (efficiency-note (intl:gettext "Unable to ~A due to type uncertainty:~@
52 ~{~6T~?~^~&~}")
53 note (messages))))))))))
54
55
56 ;;; FINALIZE-XEP-DEFINITION -- Internal
57 ;;;
58 ;;; For each named function with an XEP, note the definition of that name, and
59 ;;; add derived type information to the info environment. We also delete the
60 ;;; FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the possibility that new
61 ;;; references might be converted to it.
62 ;;;
63 (defun finalize-xep-definition (fun)
64 (let* ((leaf (functional-entry-function fun))
65 (name (leaf-name leaf))
66 (dtype (definition-type leaf)))
67 (setf (leaf-type leaf) dtype)
68 (when (ext:valid-function-name-p name)
69 (let* ((where (info function where-from name))
70 (*compiler-error-context* (lambda-bind (main-entry leaf)))
71 (global-def (gethash name *free-functions*))
72 (global-p
73 (and (defined-function-p global-def)
74 (eq (defined-function-functional global-def) leaf))))
75 (note-name-defined name :function)
76 (when global-p
77 (remhash name *free-functions*))
78 (ecase where
79 (:assumed
80 (let ((approx-type (info function assumed-type name)))
81 (when (and approx-type (function-type-p dtype))
82 (valid-approximate-type approx-type dtype))
83 (setf (info function type name) dtype)
84 (setf (info function assumed-type name) nil))
85 (setf (info function where-from name) :defined))
86 (:declared
87 (let ((type (info function type name)))
88 (when (and (function-type-p type)
89 (function-type-p dtype))
90 (let ((type-returns (function-type-returns type))
91 (dtype-returns (function-type-returns dtype))
92 (*error-function* #'compiler-warning))
93 (unless (values-types-intersect type-returns dtype-returns)
94 (note-lossage (intl:gettext "The result type from previous declaration:~% ~S~@
95 conflicts with the result type:~% ~S")
96 (type-specifier type-returns)
97 (type-specifier dtype-returns)))))))
98 (:defined
99 (when global-p
100 (setf (info function type name) dtype)))))))
101 (undefined-value))
102
103
104 ;;; NOTE-ASSUMED-TYPES -- Internal
105 ;;;
106 ;;; Find all calls in Component to assumed functions and update the assumed
107 ;;; type information. This is delayed until now so that we have the best
108 ;;; possible information about the actual argument types.
109 ;;;
110 (defun note-assumed-types (component name var)
111 (when (and (eq (leaf-where-from var) :assumed)
112 (not (and (defined-function-p var)
113 (eq (defined-function-inlinep var) :notinline)))
114 (eq (info function where-from name) :assumed)
115 (eq (info function kind name) :function))
116 (let ((atype (info function assumed-type name)))
117 (dolist (ref (leaf-refs var))
118 (let ((dest (continuation-dest (node-cont ref))))
119 (when (and (eq (block-component (node-block ref)) component)
120 (combination-p dest)
121 (eq (continuation-use (basic-combination-fun dest)) ref))
122 (setq atype (note-function-use dest atype)))))
123 (setf (info function assumed-type name) atype))))
124
125
126 ;;; IR1-FINALIZE -- Interface
127 ;;;
128 ;;; Do miscellaneous things that we want to do once all optimization has
129 ;;; been done:
130 ;;; -- Record the derived result type before the back-end trashes the
131 ;;; flow graph.
132 ;;; -- Note definition of any entry points.
133 ;;; -- Note any failed optimizations.
134 ;;;
135 (defun ir1-finalize (component)
136 (declare (type component component))
137 (dolist (fun (component-lambdas component))
138 (case (functional-kind fun)
139 (:external
140 (finalize-xep-definition fun))
141 ((nil)
142 (setf (leaf-type fun) (definition-type fun)))))
143
144 (maphash #'note-failed-optimization
145 (component-failed-optimizations component))
146
147 (maphash #'(lambda (k v)
148 (note-assumed-types component k v))
149 *free-functions*)
150 (undefined-value))

  ViewVC Help
Powered by ViewVC 1.1.5