[3d19a6]: src / compiler / ir1final.lisp Maximize Restore History

Download this file

ir1final.lisp    164 lines (152 with data), 7.0 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
;;;; This file implements the IR1 finalize phase, which checks for
;;;; various semantic errors.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!C")
;;; Give the user grief about optimizations that we weren't able to
;;; do. It is assumed that the user wants to hear about this, or there
;;; wouldn't be any entries in the table. If the node has been deleted
;;; or is no longer a known call, then do nothing; some other
;;; optimization must have gotten to it.
(defun note-failed-optimization (node failures)
(declare (type combination node) (list failures))
(unless (or (node-deleted node)
(not (eq :known (combination-kind node))))
(let ((*compiler-error-context* node))
(dolist (failure failures)
(let ((what (cdr failure))
(note (transform-note (car failure))))
(cond
((consp what)
(compiler-notify "~@<unable to ~2I~_~A ~I~_because: ~2I~_~?~:>"
note (first what) (rest what)))
((valid-fun-use node what
:argument-test #'types-equal-or-intersect
:result-test #'values-types-equal-or-intersect)
(collect ((messages))
(flet ((give-grief (string &rest stuff)
(messages string)
(messages stuff)))
(valid-fun-use node what
:unwinnage-fun #'give-grief
:lossage-fun #'give-grief))
(compiler-notify "~@<unable to ~
~2I~_~A ~
~I~_due to type uncertainty: ~
~2I~_~{~?~^~@:_~}~:>"
note (messages))))
;; As best I can guess, it's OK to fall off the end here
;; because if it's not a VALID-FUNCTION-USE, the user
;; doesn't want to hear about it. The things I caught when
;; I put ERROR "internal error: unexpected FAILURE=~S" here
;; didn't look like things we need to report. -- WHN 2001-02-07
))))))
;;; 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-FUNS* to eliminate the
;;; possibility that new references might be converted to it.
(defun finalize-xep-definition (fun)
(let* ((leaf (functional-entry-fun fun))
(defined-ftype (definition-type leaf)))
(setf (leaf-type leaf) defined-ftype)
(when (and (leaf-has-source-name-p leaf)
(eq (leaf-source-name leaf) (functional-debug-name leaf)))
(let ((source-name (leaf-source-name leaf)))
(let* ((where (info :function :where-from source-name))
(*compiler-error-context* (lambda-bind (main-entry leaf)))
(global-def (gethash source-name *free-funs*))
(global-p (defined-fun-p global-def)))
(note-name-defined source-name :function)
(when global-p
(remhash source-name *free-funs*))
(ecase where
(:assumed
(let ((approx-type (info :function :assumed-type source-name)))
(when (and approx-type (fun-type-p defined-ftype))
(valid-approximate-type approx-type defined-ftype))
(setf (info :function :type source-name) defined-ftype)
(setf (info :function :assumed-type source-name) nil))
(setf (info :function :where-from source-name) :defined))
(:declared
(let ((declared-ftype (info :function :type source-name)))
(unless (defined-ftype-matches-declared-ftype-p
defined-ftype declared-ftype)
(compiler-style-warn
"~@<The previously declared FTYPE~2I ~_~S~I ~_~
conflicts with the definition type ~2I~_~S~:>"
(type-specifier declared-ftype)
(type-specifier defined-ftype)))))
(:defined
(setf (info :function :type source-name) defined-ftype)))
(when (fasl-output-p *compile-object*)
(if (member source-name *fun-names-in-this-file* :test #'equal)
(compiler-warn "~@<Duplicate definition for ~S found in ~
one static unit (usually a file).~@:>"
source-name)
(push source-name *fun-names-in-this-file*)))))))
(values))
;;; Find all calls in COMPONENT to assumed functions and update the
;;; assumed type information. This is delayed until now so that we
;;; have the best possible information about the actual argument
;;; types.
(defun note-assumed-types (component name var)
(when (and (eq (leaf-where-from var) :assumed)
(not (and (defined-fun-p var)
(eq (defined-fun-inlinep var) :notinline)))
(eq (info :function :where-from name) :assumed)
(eq (info :function :kind name) :function))
(let ((atype (info :function :assumed-type name)))
(dolist (ref (leaf-refs var))
(let ((dest (node-dest ref)))
(when (and (eq (node-component ref) component)
(combination-p dest)
(eq (lvar-uses (basic-combination-fun dest)) ref))
(setq atype (note-fun-use dest atype)))))
(setf (info :function :assumed-type name) atype))))
;;; Merge CASTs with preceding/following nodes.
(defun ir1-merge-casts (component)
(do-blocks-backwards (block component)
(do-nodes-backwards (node lvar block)
(let ((dest (when lvar (lvar-dest lvar))))
(cond ((and (cast-p dest)
(not (cast-type-check dest))
(immediately-used-p lvar node))
(when (values-types-equal-or-intersect
(node-derived-type node)
(cast-asserted-type dest))
;; FIXME: We do not perform pathwise CAST->type-error
;; conversion, and type errors can later cause
;; backend failures. On the other hand, this version
;; produces less efficient code.
(derive-node-type node (cast-asserted-type dest))))
((and (cast-p node)
(eq (cast-type-check node) :external))
(aver (basic-combination-p dest))
(delete-filter node lvar (cast-value node))))))))
;;; 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.
;;; -- Note definition of any entry points.
;;; -- Note any failed optimizations.
(defun ir1-finalize (component)
(declare (type component component))
(dolist (fun (component-lambdas component))
(case (functional-kind fun)
(:external
(finalize-xep-definition fun))
((nil)
(setf (leaf-type fun) (definition-type fun)))))
(maphash #'note-failed-optimization
(component-failed-optimizations component))
(maphash (lambda (k v)
(note-assumed-types component k v))
*free-funs*)
(ir1-merge-casts component)
(values))