1 ;;;; This file implements the IR1 finalize phase, which checks for
2 ;;;; various semantic errors.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;; Give the user grief about optimizations that we weren't able to
16 ;;; do. It is assumed that the user wants to hear about this, or there
17 ;;; wouldn't be any entries in the table. If the node has been deleted
18 ;;; or is no longer a known call, then do nothing; some other
19 ;;; optimization must have gotten to it.
20 (defun note-failed-optimization (node failures
)
21 (declare (type combination node
) (list failures
))
22 (unless (or (node-deleted node
)
23 (not (eq :known
(combination-kind node
))))
24 (let ((*compiler-error-context
* node
))
25 (dolist (failure failures
)
26 (let ((what (cdr failure
))
27 (note (transform-note (car failure
))))
30 (compiler-notify "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
31 note
(first what
) (rest what
)))
32 ((valid-fun-use node what
33 :argument-test
#'types-equal-or-intersect
34 :result-test
#'values-types-equal-or-intersect
)
36 (flet ((give-grief (string &rest stuff
)
39 (valid-fun-use node what
40 :unwinnage-fun
#'give-grief
41 :lossage-fun
#'give-grief
))
42 (compiler-notify "~@<unable to ~
44 ~I~_due to type uncertainty: ~
47 ;; As best I can guess, it's OK to fall off the end here
48 ;; because if it's not a VALID-FUNCTION-USE, the user
49 ;; doesn't want to hear about it. The things I caught when
50 ;; I put ERROR "internal error: unexpected FAILURE=~S" here
51 ;; didn't look like things we need to report. -- WHN 2001-02-07
54 ;;; For each named function with an XEP, note the definition of that
55 ;;; name, and add derived type information to the INFO environment. We
56 ;;; also delete the FUNCTIONAL from *FREE-FUNS* to eliminate the
57 ;;; possibility that new references might be converted to it.
58 (defun finalize-xep-definition (fun)
59 (let* ((leaf (functional-entry-fun fun
))
60 (defined-ftype (definition-type leaf
)))
61 (setf (leaf-type leaf
) defined-ftype
)
62 (when (and (leaf-has-source-name-p leaf
)
63 (eq (leaf-source-name leaf
) (functional-debug-name leaf
)))
64 (let ((source-name (leaf-source-name leaf
)))
65 (let* ((where (info :function
:where-from source-name
))
66 (*compiler-error-context
* (lambda-bind (main-entry leaf
)))
67 (global-def (gethash source-name
*free-funs
*))
68 (global-p (defined-fun-p global-def
)))
69 (note-name-defined source-name
:function
)
71 (remhash source-name
*free-funs
*))
74 (let ((approx-type (info :function
:assumed-type source-name
)))
75 (when (and approx-type
(fun-type-p defined-ftype
))
76 (valid-approximate-type approx-type defined-ftype
))
77 ;; globaldb can't enforce invariants such as :assumed-type and
78 ;; :type being mutually exclusive. For that reason it would have
79 ;; made sense to use a single info-type holding either a true
80 ;; function type or an approximate-fun-type. Regardless, it is
81 ;; slightly preferable to clear the old before setting the new.
82 (clear-info :function
:assumed-type source-name
)
83 (setf (info :function
:type source-name
) defined-ftype
))
84 (setf (info :function
:where-from source-name
) :defined
))
85 ((:declared
:defined-method
)
86 (let ((declared-ftype (proclaimed-ftype source-name
)))
87 (unless (defined-ftype-matches-declared-ftype-p
88 defined-ftype declared-ftype
)
90 "~@<The previously declared FTYPE~2I ~_~S~I ~_~
91 conflicts with the definition type ~2I~_~S~:>"
92 (type-specifier declared-ftype
)
93 (type-specifier defined-ftype
)))))
95 (setf (info :function
:type source-name
) defined-ftype
)))))))
98 ;;; Find all calls in COMPONENT to assumed functions and update the
99 ;;; assumed type information. This is delayed until now so that we
100 ;;; have the best possible information about the actual argument
102 (defun note-assumed-types (component name var
)
103 (when (and (eq (leaf-where-from var
) :assumed
)
104 (not (and (defined-fun-p var
)
105 (eq (defined-fun-inlinep var
) :notinline
)))
106 (eq (info :function
:where-from name
) :assumed
)
107 (eq (info :function
:kind name
) :function
))
108 (let ((atype (info :function
:assumed-type name
)))
109 (dolist (ref (leaf-refs var
))
110 (let ((dest (node-dest ref
)))
111 (when (and (eq (node-component ref
) component
)
113 (eq (lvar-uses (basic-combination-fun dest
)) ref
))
114 (setq atype
(note-fun-use dest atype
)))))
115 (setf (info :function
:assumed-type name
) atype
))))
117 ;;; Merge CASTs with preceding/following nodes.
118 (defun ir1-merge-casts (component)
119 (do-blocks-backwards (block component
)
120 (do-nodes-backwards (node lvar block
)
121 (let ((dest (when lvar
(lvar-dest lvar
))))
122 (cond ((and (cast-p dest
)
123 (not (cast-type-check dest
))
124 (immediately-used-p lvar node
))
125 (let ((dtype (node-derived-type node
))
126 (atype (node-derived-type dest
)))
127 (when (values-types-equal-or-intersect
129 ;; FIXME: We do not perform pathwise CAST->type-error
130 ;; conversion, and type errors can later cause
131 ;; backend failures. On the other hand, this version
132 ;; produces less efficient code.
134 ;; This is sorta DERIVE-NODE-TYPE, but does not try
135 ;; to optimize the node.
136 (setf (node-derived-type node
)
137 (values-type-intersection dtype atype
)))))
139 (eq (cast-type-check node
) :external
))
140 (aver (basic-combination-p dest
))
141 (delete-filter node lvar
(cast-value node
))))))))
143 (defglobal *two-arg-functions
*
151 (char-equal two-arg-char-equal
)
152 (char-greaterp two-arg-char-greaterp
)
153 (char-lessp two-arg-char-lessp
)
154 (char-not-equal two-arg-char-not-equal
)
155 (char-not-greaterp two-arg-char-not-greaterp
)
156 (char-not-lessp two-arg-char-not-lessp
)
163 (string= two-arg-string
=)
164 (string-equal two-arg-string-equal
)
165 (string< two-arg-string
<)
166 (string> two-arg-string
>)
167 (string<= two-arg-string
<=)
168 (string>= two-arg-string
>=)
169 (string/= two-arg-string
/=)
170 (string-lessp two-arg-string-lessp
)
171 (string-greaterp two-arg-string-greaterp
)
172 (string-not-lessp two-arg-string-not-lessp
)
173 (string-not-greaterp two-arg-string-not-greaterp
)
174 (string-not-equal two-arg-string-not-equal
)))
176 (defmacro def-two-arg-fun
(function)
177 (let ((name (symbolicate 'two-arg- function
)))
179 (defknown ,name
(t t
) t
())
182 (pushnew (list ',function
',name
) *two-arg-functions
* :key
#'car
))))
184 (defmacro def-two-arg-funs
(&body functions
)
186 ,@(loop for fun in functions
187 collect
`(def-two-arg-fun ,fun
))))
190 char
= char
/= char
< char
> char
<= char
>=
193 ;;; Convert function designators to functions in calls to known functions
194 ;;; Also convert to TWO-ARG- variants
195 (defun ir1-optimize-functional-arguments (component)
196 (do-blocks (block component
)
197 (do-nodes (node nil block
)
198 (when (and (combination-p node
)
199 (eq (combination-kind node
) :known
))
200 (let* ((comination-name (lvar-fun-name (combination-fun node
) t
))
201 (type (info :function
:type comination-name
))
202 (info (info :function
:info comination-name
))
203 (args (combination-args node
)))
205 (fun-info-functional-args info
))
206 (let ((fun-lvars (apply (fun-info-functional-args info
)
207 (resolve-key-args args type
))))
208 (loop for
(fun . arg-count
) in fun-lvars
209 ;; TODO: handle CASTS.
210 ;; principal-lvar-use will return the REF but the
211 ;; CAST itself needs to be replaced.
212 for ref
= (lvar-uses fun
)
215 (flet ((translate-two-args (name)
216 (and (eql arg-count
2)
217 (neq comination-name
'reduce
)
218 (cadr (assoc name
*two-arg-functions
*)))))
219 (let* ((leaf (ref-leaf ref
))
220 (fun-name (and (constant-p leaf
)
221 (constant-value leaf
)))
225 (or (translate-two-args fun-name
)
227 ((and (global-var-p leaf
)
228 (eq (global-var-kind leaf
) :global-function
))
229 (translate-two-args (global-var-%source-name leaf
))))))
233 (let ((*compiler-error-context
* node
))
234 (find-free-fun replacement
"ir1-finalize")))))))))
235 (let ((two-arg (cadr (assoc comination-name
*two-arg-functions
*)))
236 (ref (lvar-uses (combination-fun node
))))
242 (find-free-fun two-arg
"ir1-finalize")))))))))
244 ;;; Do miscellaneous things that we want to do once all optimization
246 ;;; -- Record the derived result type before the back-end trashes the
248 ;;; -- Note definition of any entry points.
249 ;;; -- Note any failed optimizations.
250 (defun ir1-finalize (component)
251 (declare (type component component
))
252 (dolist (fun (component-lambdas component
))
253 (case (functional-kind fun
)
255 (finalize-xep-definition fun
))
257 (setf (leaf-type fun
) (definition-type fun
)))))
259 (maphash #'note-failed-optimization
260 (component-failed-optimizations component
))
262 (maphash (lambda (k v
)
263 (note-assumed-types component k v
))
266 (ir1-merge-casts component
)
267 (ir1-optimize-functional-arguments component
)