Declare COERCE and two helpers as EXPLICIT-CHECK.
[sbcl.git] / src / compiler / globaldb.lisp
blobfae7f88dcb26ae823247b678c0653c7bded4fa8f
1 ;;;; This file provides a functional interface to global information
2 ;;;; about named things in the system. Information is considered to be
3 ;;;; global if it must persist between invocations of the compiler. The
4 ;;;; use of a functional interface eliminates the need for the compiler
5 ;;;; to worry about the actual representation. This is important, since
6 ;;;; the information may well have several representations.
7 ;;;;
8 ;;;; The database contains arbitrary Lisp values, addressed by a
9 ;;;; <Name,Info-Number> pair, where Info-Number is identified by
10 ;;;; a <Category,Kind> pair, each being a keyword. The Name is a thing
11 ;;;; which we are recording information about. [Names are compared by EQUAL.]
12 ;;;; Category and Kind create a taxonomy of the data values for a thing.
13 ;;;; For example, '+ names both a function and a variable, so has (at least)
14 ;;;; two categories of information. Within each category, we have several
15 ;;;; pieces of info, and in fact some of these have the same-named :Kind
16 ;;;; such as <:FUNCTION,:TYPE> and <:VARIABLE,:TYPE>.
17 ;;;; (And sometimes the Kind is literally :KIND, as a consequence of
18 ;;;; how users of the database desire to name their keys.)
20 ;;;; The relation between this file and 'info-vectors' is that the
21 ;;;; latter provides a fundamental mechanism to create property-list-like
22 ;;;; things whose "indicators" are restricted to small integers.
23 ;;;; The globaldb abstraction is layered on top of that and is responsible
24 ;;;; for translating <Category,Kind> to a small integer.
26 ;;;; This software is part of the SBCL system. See the README file for
27 ;;;; more information.
28 ;;;;
29 ;;;; This software is derived from the CMU CL system, which was
30 ;;;; written at Carnegie Mellon University and released into the
31 ;;;; public domain. The software is in the public domain and is
32 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
33 ;;;; files for more information.
35 (in-package "SB!C")
37 #-no-ansi-print-object
38 (defmethod print-object ((x meta-info) stream)
39 (print-unreadable-object (x stream)
40 (format stream "~S ~S, ~D" (meta-info-category x) (meta-info-kind x)
41 (meta-info-number x))))
43 (!begin-collecting-cold-init-forms)
44 #!+sb-show (!cold-init-forms (/show0 "early in globaldb.lisp cold init"))
46 ;;; This is sorta semantically equivalent to SXHASH, but better-behaved for
47 ;;; legal function names. It performs more work by not cutting off as soon
48 ;;; in the CDR direction, thereby improving the distribution of method names.
49 ;;; More work here equates to less work in the global hashtable.
50 ;;; To wit: (eq (sxhash '(foo a b c bar)) (sxhash '(foo a b c d))) => T
51 ;;; but the corresponding globaldb-sxhashoids differ.
52 ;;; This is no longer inline because for the cases where it is needed -
53 ;;; names which are not just symbols or (SETF F) - an extra call has no impact.
54 (defun globaldb-sxhashoid (name)
55 ;; we can't use MIX because it's in 'target-sxhash',
56 ;; so use the host's sxhash, but ensure that the result is a target fixnum.
57 #+sb-xc-host (logand (sxhash name) sb!xc:most-positive-fixnum)
58 #-sb-xc-host
59 (locally
60 (declare (optimize (safety 0))) ; after the argc check
61 ;; TRAVERSE will walk across more cons cells than RECURSE will descend.
62 ;; That's why this isn't just one self-recursive function.
63 (labels ((traverse (accumulator x length-limit)
64 (declare (fixnum length-limit))
65 (cond ((atom x) (sb!int:mix (sxhash x) accumulator))
66 ((zerop length-limit) accumulator)
67 (t (traverse (sb!int:mix (recurse (car x) 4) accumulator)
68 (cdr x) (1- length-limit)))))
69 (recurse (x depthoid) ; depthoid = a blend of level and length
70 (declare (fixnum depthoid))
71 (cond ((atom x) (sxhash x))
72 ((zerop depthoid)
73 #.(logand sb!xc:most-positive-fixnum #36Rglobaldbsxhashoid))
74 (t (sb!int:mix (recurse (car x) (1- depthoid))
75 (recurse (cdr x) (1- depthoid)))))))
76 (traverse 0 name 10))))
78 ;;; Given any non-negative integer, return a prime number >= to it.
79 ;;;
80 ;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
81 ;;; hash-table.lisp. Perhaps the merged logic should be
82 ;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
83 ;;; after integral powers of two:
84 ;;; #(17 37 67 131 ..)
85 ;;; (Or, if that's too coarse, after half-integral powers of two.) By
86 ;;; thus getting rid of any need for primality testing at runtime, we
87 ;;; could punt POSITIVE-PRIMEP, too.
88 (defun primify (x)
89 (declare (type unsigned-byte x))
90 (do ((n (logior x 1) (+ n 2)))
91 ((positive-primep n) n)))
93 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
94 ;;; running the cross-compiler? The cross-compiler (which was built
95 ;;; from these sources) has its version of these data and functions
96 ;;; defined in the same places we'd be defining into. We're happy with
97 ;;; its version, since it was compiled from the same sources, so
98 ;;; there's no point in overwriting its nice compiled version of this
99 ;;; stuff with our interpreted version. (And any time we're *not*
100 ;;; happy with its version, perhaps because we've been editing the
101 ;;; sources partway through bootstrapping, tch tch, overwriting its
102 ;;; version with our version would be unlikely to help, because that
103 ;;; would make the cross-compiler very confused.)
104 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
105 (defun !register-meta-info (metainfo)
106 (let* ((name (meta-info-kind metainfo))
107 (list (!get-meta-infos name)))
108 (set-info-value name +info-metainfo-type-num+
109 (cond ((not list) metainfo) ; unique, just store it
110 ((listp list) (cons metainfo list)) ; prepend to the list
111 (t (list metainfo list)))))) ; convert atom to a list
113 (defun !%define-info-type (category kind type-spec type-checker
114 validate-function default &optional id)
115 (awhen (meta-info category kind nil) ; if found
116 (when id
117 (aver (= (meta-info-number it) id)))
118 (return-from !%define-info-type it)) ; do nothing
119 (let ((id (or id (position nil *info-types* :start 1)
120 (error "no more INFO type numbers available"))))
121 (!register-meta-info
122 (setf (aref *info-types* id)
123 (!make-meta-info id category kind type-spec type-checker
124 validate-function default)))))
126 ) ; EVAL-WHEN
128 #-sb-xc
129 (setf (get '!%define-info-type :sb-cold-funcall-handler/for-effect)
130 (lambda (category kind type-spec checker validator default id)
131 ;; The SB!FASL: symbols are poor style, but the lesser evil.
132 ;; If exported, then they'll stick around in the target image.
133 ;; Perhaps SB-COLD should re-export some of these.
134 (declare (special sb!fasl::*dynamic* sb!fasl::*cold-layouts*))
135 (let ((layout (gethash 'meta-info sb!fasl::*cold-layouts*)))
136 (sb!fasl::cold-svset
137 (sb!fasl::cold-symbol-value '*info-types*)
139 (sb!fasl::write-slots
140 (sb!fasl::allocate-struct sb!fasl::*dynamic* layout)
141 'meta-info ; give the type name in lieu of layout
142 :category category :kind kind :type-spec type-spec
143 :type-checker checker :validate-function validator
144 :default default :number id)))))
146 (!cold-init-forms
147 (dovector (x (the simple-vector *info-types*))
148 ;; Genesis writes the *INFO-TYPES* array, but setting up the mapping
149 ;; from keyword-pair to object is deferred until cold-init.
150 (when x (!register-meta-info x))))
152 ;;;; info types, and type numbers, part II: what's
153 ;;;; needed only at compile time, not at run time
155 ;;; Define a new type of global information.
156 ;;; CATEGORY/KIND form a two-part name for the piece of information,
157 ;;; DEFAULT is a defaulting expression, and TYPE-SPEC
158 ;;; is a type specifier which data values must satisfy.
159 ;;; Roughly speaking there is a hierarchy to the two-piece names
160 ;;; but this is a fiction that is not maintained anywhere in the internals.
162 ;;; If the defaulting expression's value is a function, it is called with
163 ;;; the name for which the information is being looked up; otherwise it is
164 ;;; taken as the default value. The defaulting expression is used each time
165 ;;; a value is needed when one hasn't been previously set. (The result
166 ;;; does not automatically become the new value for the piece of info.)
167 ;;; Should a default value be itself a function, this must be expressed as
168 ;;; :DEFAULT (CONSTANTLY #'<a-function-name>) to adhere to the convention
169 ;;; that default objects satisfying FUNCTIONP will always be funcalled.
171 (eval-when (:compile-toplevel :execute)
172 ;; This convoluted idiom creates a macro that disappears from the target,
173 ;; kind of an alternative to the "!" name convention.
174 (#+sb-xc-host defmacro
175 #-sb-xc-host sb!xc:defmacro
176 define-info-type ((category kind)
177 &key (type-spec (missing-arg))
178 (validate-function)
179 default)
180 (declare (type keyword category kind))
181 ;; There was formerly a remark that (COPY-TREE TYPE-SPEC) ensures repeatable
182 ;; fasls. That's not true now, probably never was. A compiler is permitted to
183 ;; coalesce EQUAL quoted lists and there's no defense against it, so why try?
184 (let ((form
185 `(!%define-info-type
186 ,category ,kind ',type-spec
187 ,(cond ((eq type-spec 't) '#'identity)
188 ;; evil KLUDGE to avoid "undefined type" warnings
189 ;; when building the cross-compiler.
190 #+sb-xc-host
191 ((member type-spec
192 '((or fdefn null)
193 (or alien-type null) (or heap-alien-info null))
194 :test 'equal)
195 `(lambda (x)
196 (declare (notinline typep))
197 (if (typep x ',type-spec)
199 (error "~S is not a ~S" x ',type-spec))))
201 `(named-lambda "check-type" (x) (the ,type-spec x))))
202 ,validate-function ,default
203 ;; Rationale for hardcoding here is explained at INFO-VECTOR-FDEFN.
204 ,(or (and (eq category :function) (eq kind :definition)
205 +fdefn-info-num+)
206 #+sb-xc (meta-info-number (meta-info category kind))))))
207 `(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ,form))))
210 (macrolet ((meta-info-or-lose (category kind)
211 ;; don't need to type-check META-INFO's result, since it
212 ;; defaults to signaling an error if no meta-info found.
213 `(truly-the meta-info (meta-info ,category ,kind))))
214 ;;; INFO is the standard way to access the database. It's settable.
216 ;;; Return the information of the specified CATEGORY and KIND for NAME.
217 ;;; The second value returned is true if there is any such information
218 ;;; recorded. If there is no information, the first value returned is
219 ;;; the default and the second value returned is NIL.
220 (defun info (category kind name)
221 (let ((info (meta-info category kind)))
222 (get-info-value name (meta-info-number info))))
224 (defun (setf info) (new-value category kind name)
225 (let ((info (meta-info category kind)))
226 (funcall (meta-info-type-checker info) new-value)
227 (awhen (meta-info-validate-function info)
228 (funcall it name new-value))
229 (set-info-value name (meta-info-number info) new-value)))
231 ;; Clear the information of the specified CATEGORY and KIND for NAME in
232 ;; the current environment. Return true if there was any info.
233 (defun clear-info (category kind name)
234 (let* ((info (meta-info category kind))
235 (info-number-list (list (meta-info-number info))))
236 (declare (dynamic-extent info-number-list))
237 (clear-info-values name info-number-list))))
239 (defun clear-info-values (name info-numbers)
240 (dolist (type info-numbers)
241 (aver (and (typep type 'info-number) (svref *info-types* type))))
242 ;; A call to UNCROSS was suspiciously absent, so I added this ERROR
243 ;; to be certain that it's not supposed to happen when building the xc.
244 #+sb-xc-xhost (error "Strange CLEAR-INFO building the xc: ~S ~S"
245 name info-numbers)
246 (let (new)
247 (with-globaldb-name (key1 key2) name
248 :simple
249 ;; If PACKED-INFO-REMOVE has nothing to do, it returns NIL,
250 ;; corresponding to the input that UPDATE-SYMBOL-INFO expects.
251 (dx-flet ((clear-simple (old)
252 (setq new (packed-info-remove old key2 info-numbers))))
253 (update-symbol-info key1 #'clear-simple))
254 :hairy
255 ;; The global hashtable is not imbued with knowledge of the convention
256 ;; for PACKED-INFO-REMOVE because that would render it less useful
257 ;; as a general-purpose global hashtable for other kinds of stuff
258 ;; that I might want it to store aside from packed infos.
259 ;; So here UPDATE might receive NIL but must not return NIL if
260 ;; there was a non-nil input. NIL doesn't mean "do nothing".
261 (dx-flet ((clear-hairy (old)
262 (if old
263 ;; if -REMOVE => nil, then update NEW but return OLD
264 (or (setq new (packed-info-remove
265 old +no-auxilliary-key+ info-numbers))
266 old))))
267 (info-puthash *info-environment* name #'clear-hairy)))
268 (not (null new))))
270 ;;;; *INFO-ENVIRONMENT*
272 (!cold-init-forms
273 (setq *info-environment* (make-info-hashtable))
274 (/show0 "done setting *INFO-ENVIRONMENT*"))
276 ;;;; GET-INFO-VALUE
278 ;;; If non-nil, *GLOBALDB-OBSERVER*'s CAR is a bitmask over info numbers
279 ;;; for which you'd like to call the function in the CDR whenever info
280 ;;; of that number is queried.
281 (!defvar *globaldb-observer* nil)
282 (declaim (type (or (cons (unsigned-byte #.(ash 1 info-number-bits)) function)
283 null) *globaldb-observer*))
284 #-sb-xc-host (declaim (always-bound *globaldb-observer*))
286 ;;; Return the value of NAME / INFO-NUMBER from the global environment,
287 ;;; or return the default if there is no global info.
288 ;;; The secondary value indicates whether info was found vs defaulted.
289 (declaim (ftype (sfunction (t info-number) (values t boolean))
290 get-info-value))
291 (defun get-info-value (name info-number)
292 (let* ((hook *globaldb-observer*)
293 (hookp (and (and hook
294 (not (eql 0 (car hook)))
295 (logbitp info-number (car hook))))))
296 (multiple-value-bind (vector aux-key)
297 (let ((name (uncross name)))
298 (with-globaldb-name (key1 key2) name
299 ;; In the :simple branch, KEY1 is no doubt a symbol,
300 ;; but constraint propagation isn't informing the compiler here.
301 :simple (values (symbol-info-vector (truly-the symbol key1)) key2)
302 :hairy (values (info-gethash name *info-environment*)
303 +no-auxilliary-key+)))
304 (when vector
305 (let ((index (packed-info-value-index vector aux-key info-number)))
306 (when index
307 (let ((answer (svref vector index)))
308 (when hookp
309 (funcall (truly-the function (cdr hook))
310 name info-number answer t))
311 (return-from get-info-value (values answer t)))))))
312 (let* ((def (meta-info-default (aref *info-types* info-number)))
313 (answer (if (functionp def) (funcall def name) def)))
314 (when hookp
315 (funcall (truly-the function (cdr hook)) name info-number answer nil))
316 (values answer nil))))
318 ;; interface to %ATOMIC-SET-INFO-VALUE
319 ;; GET-INFO-VALUE-INITIALIZING is a restricted case of this,
320 ;; and perhaps could be implemented as such.
321 ;; Atomic update will be important for making the fasloader threadsafe
322 ;; using a predominantly lock-free design, and other nice things.
323 (def!macro atomic-set-info-value (category kind name lambda)
324 (with-unique-names (info-number proc)
325 `(let ((,info-number
326 ,(if (and (keywordp category) (keywordp kind))
327 (meta-info-number (meta-info category kind))
328 `(meta-info-number (meta-info ,category ,kind)))))
329 ,(if (and (listp lambda) (eq (car lambda) 'lambda))
330 ;; rewrite as FLET because the compiler is unable to dxify
331 ;; (DX-LET ((x (LAMBDA <whatever>))) (F x))
332 (destructuring-bind (lambda-list . body) (cdr lambda)
333 `(dx-flet ((,proc ,lambda-list ,@body))
334 (%atomic-set-info-value ,name ,info-number #',proc)))
335 `(%atomic-set-info-value ,name ,info-number ,lambda)))))
337 ;; Call FUNCTION once for each Name in globaldb that has information associated
338 ;; with it, passing the function the Name as its only argument.
340 (defun call-with-each-globaldb-name (fun-designator)
341 (let ((function (coerce fun-designator 'function)))
342 (with-package-iterator (iter (list-all-packages) :internal :external)
343 (loop (multiple-value-bind (winp symbol access package) (iter)
344 (declare (ignore access))
345 (if (not winp) (return))
346 ;; Try to process each symbol at most once by associating it with
347 ;; a single package. If a symbol is apparently uninterned,
348 ;; always keep it since we can't know if it has been seen once.
349 (when (or (not (symbol-package symbol))
350 (eq package (symbol-package symbol)))
351 (dolist (name (info-vector-name-list symbol))
352 (funcall function name))))))
353 (info-maphash (lambda (name data)
354 (declare (ignore data))
355 (funcall function name))
356 *info-environment*)))
358 ;;;; ":FUNCTION" subsection - Data pertaining to globally known functions.
360 (define-info-type (:function :definition) :type-spec (or fdefn null))
362 ;;; the kind of functional object being described. If null, NAME isn't
363 ;;; a known functional object.
364 (define-info-type (:function :kind)
365 :type-spec (member nil :function :macro :special-form)
366 ;; I'm a little confused what the correct behavior of this default
367 ;; is. It's not clear how to generalize the FBOUNDP expression to
368 ;; the cross-compiler. As far as I can tell, NIL is a safe default
369 ;; -- it might keep the compiler from making some valid
370 ;; optimization, but it shouldn't produce incorrect code. -- WHN
371 ;; 19990330
372 :default
373 #+sb-xc-host nil
374 #-sb-xc-host (lambda (name) (if (fboundp name) :function nil)))
376 ;;; Indicates whether the function is deprecated.
377 (define-info-type (:function :deprecated) :type-spec deprecation-info)
379 (declaim (ftype (sfunction (t) ctype)
380 specifier-type ctype-of sb!kernel::ctype-of-array))
382 ;;; The type specifier for this function.
383 (define-info-type (:function :type)
384 :type-spec ctype
385 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's
386 ;; not clear how to generalize the FBOUNDP expression to the
387 ;; cross-compiler. -- WHN 19990330
388 :default
389 ;; Delay evaluation of (SPECIFIER-TYPE) since it can't work yet
390 #+sb-xc-host (lambda (x) (declare (ignore x)) (specifier-type 'function))
391 #-sb-xc-host (lambda (name)
392 (if (fboundp name)
393 (handler-bind ((style-warning #'muffle-warning))
394 (specifier-type (sb!impl::%fun-type (fdefinition name))))
395 (specifier-type 'function))))
397 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
398 ;;; due to not having a declaration or definition
399 (define-info-type (:function :assumed-type)
400 ;; FIXME: The type-spec really should be
401 ;; (or approximate-fun-type null)).
402 ;; It was changed to T as a hopefully-temporary hack while getting
403 ;; cold init problems untangled.
404 :type-spec t)
406 ;;; where this information came from:
407 ;;; :ASSUMED = from uses of the object
408 ;;; :DEFINED = from examination of the definition
409 ;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
410 ;;; :DECLARED = from a declaration
411 ;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
412 ;;; and :DECLARED trumps :DEFINED-METHOD.
413 ;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
414 ;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
415 ;;; code which implements the function, or which uses the function's
416 ;;; return values.
417 (define-info-type (:function :where-from)
418 :type-spec (member :declared :defined-method :assumed :defined)
419 :default
420 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :KIND) ...)] it's
421 ;; not clear how to generalize the FBOUNDP expression to the
422 ;; cross-compiler. -- WHN 19990606
423 #+sb-xc-host :assumed
424 #-sb-xc-host (lambda (name) (if (fboundp name) :defined :assumed)))
426 ;;; something which can be decoded into the inline expansion of the
427 ;;; function, or NIL if there is none
429 ;;; To inline a function, we want a lambda expression, e.g.
430 ;;; '(LAMBDA (X) (+ X 1)).
431 (define-info-type (:function :inline-expansion-designator)
432 :type-spec list)
434 ;;; This specifies whether this function may be expanded inline. If
435 ;;; null, we don't care.
436 (define-info-type (:function :inlinep) :type-spec inlinep)
438 ;;; Track how many times IR2 converted a call to this function as a full call
439 ;;; that was not in the scope of a local or global notinline declaration.
440 ;;; Useful for finding functions that were supposed to have been converted
441 ;;; through some kind of transformation but were not.
442 (define-info-type (:function :emitted-full-calls) :type-spec list)
444 ;;; a macro-like function which transforms a call to this function
445 ;;; into some other Lisp form. This expansion is inhibited if inline
446 ;;; expansion is inhibited.
447 ;;; As an exception, a cons of two atoms represents structure metadata
448 ;;; which is recognized and transformed in a stylized way.
449 (define-info-type (:function :source-transform)
450 :type-spec (or function null (cons atom atom)))
452 ;;; the macroexpansion function for this macro
453 (define-info-type (:function :macro-function) :type-spec (or function null))
455 ;;; the compiler-macroexpansion function for this function or macro
456 (define-info-type (:function :compiler-macro-function)
457 :type-spec (or function null))
459 ;;; a function which converts this special form into IR1
460 (define-info-type (:function :ir1-convert) :type-spec (or function null))
462 ;;; If a function is "known" to the compiler, then this is a FUN-INFO
463 ;;; structure containing the info used to special-case compilation.
464 (define-info-type (:function :info) :type-spec (or fun-info null))
466 ;;; This is a type specifier <t> such that if an argument X to the function
467 ;;; does not satisfy (TYPEP x <t>) then the function definitely returns NIL.
468 ;;; When the named function is a predicate that appears in (SATISFIES p)
469 ;;; specifiers, it is possible for type operations to see into the predicate
470 ;;; just enough to determine that something like
471 ;;; (AND (SATISFIES UNINTERESTING-METHOD-REDEFINITION-P) RATIONAL)
472 ;;; is *empty-type*, which in turn avoids type cache pollution.
473 (define-info-type (:function :predicate-truth-constraint) :type-spec t)
475 ;;;; ":VARIABLE" subsection - Data pertaining to globally known variables.
477 ;;; the kind of variable-like thing described
478 (define-info-type (:variable :kind)
479 :type-spec (member :special :constant :macro :global :alien :unknown)
480 :default (lambda (name)
481 (if (typep name '(or boolean keyword))
482 :constant
483 :unknown)))
485 (define-info-type (:variable :always-bound)
486 :type-spec (member nil :eventually :always-bound))
488 (define-info-type (:variable :deprecated) :type-spec deprecation-info)
490 ;;; the declared type for this variable
491 (define-info-type (:variable :type)
492 :type-spec ctype
493 ;; This gets set to *UNIVERSAL-TYPE* in 'late-type'
494 :default (lambda (x) (declare (ignore x)) (error "Too early for INFO")))
496 ;;; where this type and kind information came from
497 (define-info-type (:variable :where-from)
498 :type-spec (member :declared :assumed :defined) :default :assumed)
500 ;;; the macro-expansion for symbol-macros
501 (define-info-type (:variable :macro-expansion) :type-spec t)
503 (define-info-type (:variable :alien-info)
504 :type-spec (or heap-alien-info null))
506 (define-info-type (:variable :documentation) :type-spec (or string null))
508 ;; :WIRED-TLS describes how SYMBOL-VALUE (implicit or not) should be compiled.
509 ;; - :ALWAYS-HAS-TLS means that calls to SYMBOL-VALUE should access the TLS
510 ;; with a fixed offset. The index is assigned no later than load-time of
511 ;; the file containing code thus compiled. Presence of an index in the
512 ;; image that performed compilation is irrelevant (for now).
513 ;; - :ALWAYS-THREAD-LOCAL implies a fixed offset, *and* that the check for
514 ;; no-tls-value may be elided. There is currently no way to set this.
515 ;; Note that this does not affect elision of the check for unbound-marker
516 ;; which is under control of the :ALWAYS-BOUND info.
517 ;; - an integer is a permanent index, and also implies :ALWAYS-THREAD-LOCAL.
518 ;; Specials in the CL package (notably reader/printer controls) use a wired-tls,
519 ;; whether or not we bind per-thread [if we don't, that's a bug!]
520 ;; We don't assume wired TLS more generally, because user code often defines
521 ;; thousands of DEFVARs, possibly due to poor style, or due to ANSI's stance
522 ;; that DEFCONSTANT is only for EQL-comparable objects. In such cases with
523 ;; more symbols than can be bound per-thread, the compiler won't exacerbate
524 ;; things by making the loader eagerly assign a TLS index to every symbol
525 ;; ever referenced by SYMBOL-VALUE or SET. Depletion should occur lazily.
527 (define-info-type (:variable :wired-tls)
528 :type-spec (or (member nil :always-has-tls :always-thread-local)
529 fixnum) ; the actual index, for thread slots (to be done)
530 :default
531 (lambda (symbol)
532 (declare (symbol symbol))
533 (and (eq (info :variable :kind symbol) :special)
534 #-sb-xc-host
535 (eq (symbol-package symbol) *cl-package*)
536 #+sb-xc-host
537 (flet ((external-in-package-p (pkg)
538 (and (string= (package-name (symbol-package symbol)) pkg)
539 (eq (nth-value 1 (find-symbol (string symbol) pkg))
540 :external))))
541 ;; I'm not worried about random extra externals in some bizarro
542 ;; host lisp. TLS assignment has no bearing on semantics at all.
543 (or (external-in-package-p "COMMON-LISP")
544 (external-in-package-p "SB-XC")))
545 :always-has-tls)))
547 ;;;; ":TYPE" subsection - Data pertaining to globally known types.
549 ;;; the kind of type described. We return :INSTANCE for standard types
550 ;;; that are implemented as structures. For PCL classes, that have
551 ;;; only been compiled, but not loaded yet, we return
552 ;;; :FORTHCOMING-DEFCLASS-TYPE.
553 ;;; The only major distinction between :PRIMITIVE and :DEFINED
554 ;;; is how badly the system complains about attempted redefinition.
555 (define-info-type (:type :kind)
556 :type-spec (member :primitive :defined :instance
557 :forthcoming-defclass-type nil)
558 :validate-function (lambda (name new-value)
559 (declare (ignore new-value))
560 ;; The compiler-macro signals an error
561 ;; on forward-referenced info-types.
562 #+sb-xc-host (declare (notinline info))
563 (when (info :declaration :recognized name)
564 (error 'declaration-type-conflict-error
565 :format-arguments (list name)))))
567 (define-info-type (:type :documentation) :type-spec (or string null))
569 ;;; Either a CTYPE which is the translation of this type name,
570 ;;; or a function that parses type specifiers into CTYPE structures.
571 ;;; The :BUILTIN property is mutually exclusive with a CTYPE stored here.
572 ;;; :BUILTIN could probably be eliminated, as it is redundant since we
573 ;;; can discern a :BUILTIN by its :KIND being :PRIMITIVE.
574 (define-info-type (:type :translator)
575 :type-spec (or function ctype null)
576 ;; This error is never seen by a user. After meta-compile there is no
577 ;; means to define additional types with custom translators.
578 :validate-function (lambda (name new-value)
579 ;; The compiler-macro signals an error
580 ;; on forward-referenced info-types.
581 #+sb-xc-host (declare (notinline info))
582 (when (and new-value (info :type :expander name))
583 (bug "Type has an expander"))
584 (when (and (not (functionp new-value))
585 new-value
586 (info :type :builtin name))
587 (bug ":BUILTIN and :TRANSLATOR are incompatible"))))
589 ;;; The expander function for a defined type.
590 ;;; It returns a type expression, not a CTYPE.
591 (define-info-type (:type :expander)
592 :type-spec (or function null)
593 ;; This error is never seen by a user.
594 ;; The user sees "illegal to redefine standard type".
595 :validate-function (lambda (name new-value)
596 (when (and new-value (info :type :translator name))
597 (bug "Type has a translator"))))
599 ;;; If true, then the type coresponding to this name. Note that if
600 ;;; this is a built-in class with a translation, then this is the
601 ;;; translation, not the class object. This info type keeps track of
602 ;;; various atomic types (NIL etc.) and also serves as a means to
603 ;;; ensure that common standard types are only consed once.
604 (define-info-type (:type :builtin)
605 :type-spec (or ctype null)
606 :validate-function (lambda (name new-value)
607 (when (and (ctype-p new-value)
608 (ctype-p (info :type :translator name)))
609 (bug ":BUILTIN and :TRANSLATOR are incompatible"))))
611 ;;; The classoid-cell for this type
612 (define-info-type (:type :classoid-cell) :type-spec t)
614 (defun find-classoid-cell (name &key create)
615 (let ((real-name (uncross name)))
616 (cond ((info :type :classoid-cell real-name))
617 (create
618 (get-info-value-initializing
619 :type :classoid-cell real-name
620 (sb!kernel::make-classoid-cell real-name))))))
622 ;;; Return the classoid with the specified NAME. If ERRORP is false,
623 ;;; then NIL is returned when no such class exists.
624 (defun find-classoid (name &optional (errorp t))
625 (declare (type symbol name))
626 (let ((cell (find-classoid-cell name)))
627 (cond ((and cell (classoid-cell-classoid cell)))
628 (errorp
629 (error 'simple-type-error
630 :datum nil
631 :expected-type 'class
632 :format-control "Class not yet defined: ~S"
633 :format-arguments (list name))))))
635 ;;; layout for this type being used by the compiler
636 (define-info-type (:type :compiler-layout)
637 :type-spec (or layout null)
638 :default (lambda (name)
639 (let ((class (find-classoid name nil)))
640 (when class (classoid-layout class)))))
642 ;;; DEFTYPE lambda-list
643 ;; FIXME: remove this after making swank-fancy-inspector not use it.
644 (define-info-type (:type :lambda-list) :type-spec t)
646 (define-info-type (:type :source-location) :type-spec t)
648 ;;; Indicates whether the function is deprecated.
649 (define-info-type (:type :deprecated) :type-spec deprecation-info)
651 ;;;; ":TYPED-STRUCTURE" subsection.
652 ;;;; Data pertaining to structures that used DEFSTRUCT's :TYPE option.
653 (define-info-type (:typed-structure :info) :type-spec t)
654 (define-info-type (:typed-structure :documentation) :type-spec (or string null))
656 ;;;; ":DECLARATION" subsection - Data pertaining to user-defined declarations.
657 ;; CLTL2 offers an API to provide a list of known declarations, but it is
658 ;; inefficient to iterate over all symbols to find ones which have the
659 ;; (:DECLARATION :RECOGNIZED) info.
660 ;; Therefore maintain a list of recognized declarations. This list makes the
661 ;; globaldb storage of same redundant, but oh well.
662 (defglobal *recognized-declarations* nil)
663 (define-info-type (:declaration :recognized)
664 :type-spec boolean
665 ;; There's no portable way to unproclaim that a symbol is a declaration,
666 ;; but at the low-level permit new-value to be NIL.
667 :validate-function (lambda (name new-value)
668 (declare (symbol name))
669 (cond (new-value
670 (when (info :type :kind name)
671 (error 'declaration-type-conflict-error
672 :format-arguments (list name)))
673 (pushnew name *recognized-declarations*))
675 (setq *recognized-declarations*
676 (delete name *recognized-declarations*))))))
678 (define-info-type (:declaration :handler) :type-spec (or function null))
680 ;;;; ":ALIEN-TYPE" subsection - Data pertaining to globally known alien-types.
681 (define-info-type (:alien-type :kind)
682 :type-spec (member :primitive :defined :unknown)
683 :default :unknown)
684 (define-info-type (:alien-type :translator) :type-spec (or function null))
685 (define-info-type (:alien-type :definition) :type-spec (or alien-type null))
686 (define-info-type (:alien-type :struct) :type-spec (or alien-type null))
687 (define-info-type (:alien-type :union) :type-spec (or alien-type null))
688 (define-info-type (:alien-type :enum) :type-spec (or alien-type null))
690 ;;;; ":SETF" subsection - Data pertaining to expansion of the omnipotent macro.
691 (define-info-type (:setf :inverse) :type-spec (or symbol null))
692 (define-info-type (:setf :documentation) :type-spec (or string null))
693 (define-info-type (:setf :expander)
694 :type-spec (or function (cons integer function) null))
696 ;;;; ":CAS" subsection - Like SETF but there are no "inverses", just expanders
697 (define-info-type (:cas :expander) :type-spec (or function null))
699 ;;;; ":RANDOM-DOCUMENTATION" subsection.
700 ;;; This is used for storing miscellaneous documentation types. The
701 ;;; stuff is an alist translating documentation kinds to values.
702 (define-info-type (:random-documentation :stuff) :type-spec list)
704 ;;;; ":SOURCE-LOCATION" subsection.
705 ;;; This is kind of the opposite of what I'd have thought more logical,
706 ;;; where each of the above categories has one of its kinds of information
707 ;;; being :SOURCE-LOCATION.
708 ;;; And in fact that *is* how :TYPE was handled. However, many global entities
709 ;;; store their source-location hanging off some other hook, avoiding the
710 ;;; globaldb entirely, such as functions using a #<code-component>.
711 ;;; So either way is basically a hodgepodge.
713 (define-info-type (:source-location :variable) :type-spec t)
714 (define-info-type (:source-location :constant) :type-spec t)
715 (define-info-type (:source-location :typed-structure) :type-spec t)
716 (define-info-type (:source-location :symbol-macro) :type-spec t)
717 (define-info-type (:source-location :vop) :type-spec t)
718 (define-info-type (:source-location :declaration) :type-spec t)
719 (define-info-type (:source-location :alien-type) :type-spec t)
721 ;; This is for the SB-INTROSPECT contrib module, and debugging.
722 (defun call-with-each-info (function symbol)
723 (awhen (symbol-info-vector symbol)
724 (%call-with-each-info function it symbol)))
726 ;; This is for debugging at the REPL.
727 (defun show-info (sym)
728 (let ((prev 0))
729 (call-with-each-info
730 (lambda (name type-num val)
731 (unless (eq name prev)
732 (format t "~&~S" (setq prev name)))
733 (let ((type (svref *info-types* type-num)))
734 (format t "~& ~@[type ~D~]~@[~{~S ~S~}~] = "
735 (if (not type) type-num)
736 (if type
737 (list (meta-info-category type) (meta-info-kind type))))
738 (write val :level 1)))
739 sym)))
741 (!defun-from-collected-cold-init-forms !globaldb-cold-init)