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 (info :function
:type 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 ;;; Do miscellaneous things that we want to do once all optimization
145 ;;; -- Record the derived result type before the back-end trashes the
147 ;;; -- Note definition of any entry points.
148 ;;; -- Note any failed optimizations.
149 (defun ir1-finalize (component)
150 (declare (type component component
))
151 (dolist (fun (component-lambdas component
))
152 (case (functional-kind fun
)
154 (finalize-xep-definition fun
))
156 (setf (leaf-type fun
) (definition-type fun
)))))
158 (maphash #'note-failed-optimization
159 (component-failed-optimizations component
))
161 (maphash (lambda (k v
)
162 (note-assumed-types component k v
))
165 (ir1-merge-casts component
)