1.0.34.11: properly inline %UNARY-TRUNCATE/{SINGLE,DOUBLE}-FLOAT
[sbcl.git] / src / compiler / proclaim.lisp
1 ;;;; This file contains load-time support for declaration processing.
2 ;;;; In CMU CL it was split off from the compiler so that the compiler
3 ;;;; doesn't have to be in the cold load, but in SBCL the compiler is
4 ;;;; in the cold load again, so this might not be valuable.
5
6 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; more information.
8 ;;;;
9 ;;;; This software is derived from the CMU CL system, which was
10 ;;;; written at Carnegie Mellon University and released into the
11 ;;;; public domain. The software is in the public domain and is
12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
13 ;;;; files for more information.
14
15 (in-package "SB!C")
16
17 ;;; A list of UNDEFINED-WARNING structures representing references to unknown
18 ;;; stuff which came up in a compilation unit.
19 (defvar *undefined-warnings*)
20 (declaim (list *undefined-warnings*))
21
22 ;;; Look up some symbols in *FREE-VARS*, returning the var
23 ;;; structures for any which exist. If any of the names aren't
24 ;;; symbols, we complain.
25 (declaim (ftype (function (list) list) get-old-vars))
26 (defun get-old-vars (names)
27   (collect ((vars))
28     (dolist (name names (vars))
29       (unless (symbolp name)
30         (compiler-error "The name ~S is not a symbol." name))
31       (let ((old (gethash name *free-vars*)))
32         (when old (vars old))))))
33
34 ;;; Return a new POLICY containing the policy information represented
35 ;;; by the optimize declaration SPEC. Any parameters not specified are
36 ;;; defaulted from the POLICY argument.
37 (declaim (ftype (function (list policy) policy) process-optimize-decl))
38 (defun process-optimize-decl (spec policy)
39   (let ((result nil))
40     ;; Add new entries from SPEC.
41     (dolist (q-and-v-or-just-q (cdr spec))
42       (multiple-value-bind (quality raw-value)
43           (if (atom q-and-v-or-just-q)
44               (values q-and-v-or-just-q 3)
45               (destructuring-bind (quality raw-value) q-and-v-or-just-q
46                 (values quality raw-value)))
47         (cond ((not (policy-quality-name-p quality))
48                (let ((deprecation-warning (policy-quality-deprecation-warning quality spec)))
49                  (if deprecation-warning
50                      (compiler-warn deprecation-warning)
51                      (compiler-warn "~@<Ignoring unknown optimization quality ~S in:~_ ~S~:>"
52                                     quality spec))))
53               ((not (typep raw-value 'policy-quality))
54                (compiler-warn "~@<Ignoring bad optimization value ~S in:~_ ~S~:>"
55                               raw-value spec))
56               (t
57                ;; we can't do this yet, because CLOS macros expand
58                ;; into code containing INHIBIT-WARNINGS.
59                #+nil
60                (when (eql quality 'sb!ext:inhibit-warnings)
61                  (compiler-style-warn "~S is deprecated: use ~S instead"
62                                       quality 'sb!ext:muffle-conditions))
63                (push (cons quality raw-value)
64                      result)))))
65     ;; Add any nonredundant entries from old POLICY.
66     (dolist (old-entry policy)
67       (unless (assq (car old-entry) result)
68         (push old-entry result)))
69     ;; Voila.
70     (sort-policy result)))
71
72 (declaim (ftype (function (list list) list)
73                 process-handle-conditions-decl))
74 (defun process-handle-conditions-decl (spec list)
75   (let ((new (copy-alist list)))
76     (dolist (clause (cdr spec))
77       (destructuring-bind (typespec restart-name) clause
78         (let ((ospec (rassoc restart-name new :test #'eq)))
79           (if ospec
80               (setf (car ospec)
81                     (type-specifier
82                      (type-union (specifier-type (car ospec))
83                                  (specifier-type typespec))))
84               (push (cons (type-specifier (specifier-type typespec))
85                           restart-name)
86                     new)))))
87     new))
88 (declaim (ftype (function (list list) list)
89                 process-muffle-conditions-decl))
90 (defun process-muffle-conditions-decl (spec list)
91   (process-handle-conditions-decl
92    (cons 'handle-conditions
93          (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec)))
94    list))
95
96 (declaim (ftype (function (list list) list)
97                 process-unhandle-conditions-decl))
98 (defun process-unhandle-conditions-decl (spec list)
99   (let ((new (copy-alist list)))
100     (dolist (clause (cdr spec))
101       (destructuring-bind (typespec restart-name) clause
102         (let ((ospec (rassoc restart-name new :test #'eq)))
103           (if ospec
104               (let ((type-specifier
105                      (type-specifier
106                       (type-intersection
107                        (specifier-type (car ospec))
108                        (specifier-type `(not ,typespec))))))
109                 (if type-specifier
110                     (setf (car ospec) type-specifier)
111                     (setq new
112                           (delete restart-name new :test #'eq :key #'cdr))))
113               ;; do nothing?
114               nil))))
115     new))
116 (declaim (ftype (function (list list) list)
117                 process-unmuffle-conditions-decl))
118 (defun process-unmuffle-conditions-decl (spec list)
119   (process-unhandle-conditions-decl
120    (cons 'unhandle-conditions
121          (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec)))
122    list))
123
124 (declaim (ftype (function (list list) list)
125                 process-package-lock-decl))
126 (defun process-package-lock-decl (spec old)
127   (let ((decl (car spec))
128         (list (cdr spec)))
129     (ecase decl
130       (disable-package-locks
131        (union old list :test #'equal))
132       (enable-package-locks
133        (set-difference old list :test #'equal)))))
134
135 ;;; ANSI defines the declaration (FOO X Y) to be equivalent to
136 ;;; (TYPE FOO X Y) when FOO is a type specifier. This function
137 ;;; implements that by converting (FOO X Y) to (TYPE FOO X Y).
138 (defun canonized-decl-spec (decl-spec)
139   (let ((id (first decl-spec)))
140     (let ((id-is-type (if (symbolp id)
141                           (info :type :kind id)
142                           ;; A cons might not be a valid type specifier,
143                           ;; but it can't be a declaration either.
144                           (or (consp id)
145                               (typep id 'class))))
146           (id-is-declared-decl (info :declaration :recognized id)))
147       ;; FIXME: Checking ID-IS-DECLARED is probably useless these days,
148       ;; since we refuse to use the same symbol as both a type name and
149       ;; recognized declaration name.
150       (cond ((and id-is-type id-is-declared-decl)
151              (compiler-error
152               "ambiguous declaration ~S:~%  ~
153               ~S was declared as a DECLARATION, but is also a type name."
154               decl-spec id))
155             (id-is-type
156              (cons 'type decl-spec))
157             (t
158              decl-spec)))))
159
160 (defvar *queued-proclaims*) ; initialized in !COLD-INIT-FORMS
161
162 (!begin-collecting-cold-init-forms)
163 (!cold-init-forms (setf *queued-proclaims* nil))
164 (!defun-from-collected-cold-init-forms !early-proclaim-cold-init)
165
166 (defun sb!xc:proclaim (raw-form)
167   #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..")
168   #+sb-xc (/hexstr raw-form)
169   (let* ((form (canonized-decl-spec raw-form))
170          (kind (first form))
171          (args (rest form)))
172     (case kind
173       ((special global)
174        (flet ((make-special (name old)
175                 (unless (member old '(:special :unknown))
176                   (error "Cannot proclaim a ~(~A~) variable special: ~S" old name))
177                 (with-single-package-locked-error
178                     (:symbol name "globally declaring ~A special")
179                   (setf (info :variable :kind name) :special)))
180               (make-global (name old)
181                 (unless (member old '(:global :unknown))
182                   (error "Cannot proclaim a ~(~A~) variable global: ~S" old name))
183                 (with-single-package-locked-error
184                     (:symbol name "globally declaring ~A global")
185                   (setf (info :variable :kind name) :global))))
186          (let ((fun (if (eq 'special kind) #'make-special #'make-global)))
187            (dolist (name args)
188             (unless (symbolp name)
189               (error "Can't declare a non-symbol as ~S: ~S" kind name))
190             (funcall fun name (info :variable :kind name))))))
191       (always-bound
192        (dolist (name args)
193          (unless (symbolp name)
194            (error "Can't proclaim a non-symbol as ~S: ~S" kind name))
195          (unless (boundp name)
196            (error "Can't proclaim an unbound symbol as ~S: ~S" kind name))
197          (when (eq :constant (info :variable :kind name))
198            (error "Can't proclaim a constant variable as ~S: ~S" kind name))
199          (with-single-package-locked-error
200              (:symbol name "globally declaring ~A always bound")
201            (setf (info :variable :always-bound name) t))))
202       (type
203        (if *type-system-initialized*
204            (let ((type (specifier-type (first args))))
205              (dolist (name (rest args))
206                (unless (symbolp name)
207                  (error "can't declare TYPE of a non-symbol: ~S" name))
208                (with-single-package-locked-error
209                    (:symbol name "globally declaring the type of ~A"))
210                (when (eq (info :variable :where-from name) :declared)
211                  (let ((old-type (info :variable :type name)))
212                    (when (type/= type old-type)
213                      ;; FIXME: changing to TYPE-PROCLAMATION-MISMATCH
214                      ;; broke late-proclaim.lisp.
215                      (style-warn
216                       "~@<new TYPE proclamation for ~S~@:_  ~S~@:_~
217                         does not match the old TYPE proclamation:~@:_  ~S~@:>"
218                       name (type-specifier type) (type-specifier old-type)))))
219                (setf (info :variable :type name) type)
220                (setf (info :variable :where-from name) :declared)))
221            (push raw-form *queued-proclaims*)))
222       (ftype
223        (if *type-system-initialized*
224            (let ((ctype (specifier-type (first args))))
225              (unless (csubtypep ctype (specifier-type 'function))
226                (error "not a function type: ~S" (first args)))
227              (dolist (name (rest args))
228                (with-single-package-locked-error
229                    (:symbol name "globally declaring the ftype of ~A"))
230                (when (eq (info :function :where-from name) :declared)
231                  (let ((old-type (info :function :type name)))
232                    (when (type/= ctype old-type)
233                      ;; FIXME: changing to FTYPE-PROCLAMATION-MISMATCH
234                      ;; broke late-proclaim.lisp.
235                      (style-warn
236                       "~@<new FTYPE proclamation for ~S~@:_  ~S~@:_~
237                        does not match the old FTYPE proclamation:~@:_  ~S~@:>"
238                       name (type-specifier ctype) (type-specifier old-type)))))
239
240                ;; Now references to this function shouldn't be warned
241                ;; about as undefined, since even if we haven't seen a
242                ;; definition yet, we know one is planned.
243                ;;
244                ;; Other consequences of we-know-you're-a-function-now
245                ;; are appropriate too, e.g. any MACRO-FUNCTION goes away.
246                (proclaim-as-fun-name name)
247                (note-name-defined name :function)
248
249                ;; the actual type declaration
250                (setf (info :function :type name) ctype
251                      (info :function :where-from name) :declared)))
252            (push raw-form *queued-proclaims*)))
253       (freeze-type
254        (dolist (type args)
255          (let ((class (specifier-type type)))
256            (when (typep class 'classoid)
257              (setf (classoid-state class) :sealed)
258              (let ((subclasses (classoid-subclasses class)))
259                (when subclasses
260                  (dohash ((subclass layout) subclasses :locked t)
261                    (declare (ignore layout))
262                    (setf (classoid-state subclass) :sealed))))))))
263       (optimize
264        (setq *policy* (process-optimize-decl form *policy*)))
265       (muffle-conditions
266        (setq *handled-conditions*
267              (process-muffle-conditions-decl form *handled-conditions*)))
268       (unmuffle-conditions
269        (setq *handled-conditions*
270              (process-unmuffle-conditions-decl form *handled-conditions*)))
271       ((disable-package-locks enable-package-locks)
272          (setq *disabled-package-locks*
273                (process-package-lock-decl form *disabled-package-locks*)))
274       ((inline notinline maybe-inline)
275        (dolist (name args)
276          ; since implicitly it is a function, also scrubs *FREE-FUNS*
277          (proclaim-as-fun-name name)
278          (setf (info :function :inlinep name)
279                (ecase kind
280                  (inline :inline)
281                  (notinline :notinline)
282                  (maybe-inline :maybe-inline)))))
283       (declaration
284        (dolist (decl args)
285          (unless (symbolp decl)
286            (error "In~%  ~S~%the declaration to be recognized is not a ~
287                   symbol:~%  ~S"
288                   form decl))
289          (with-single-package-locked-error
290              (:symbol decl "globally declaring ~A as a declaration proclamation"))
291          (setf (info :declaration :recognized decl) t)))
292       (t
293        (unless (info :declaration :recognized kind)
294          (compiler-warn "unrecognized declaration ~S" raw-form)))))
295   #+sb-xc (/show0 "returning from PROCLAIM")
296   (values))