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.
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.
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.
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
)
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
))
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.
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.
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
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"))))
122 (setf (aref *info-types
* id
)
123 (!make-meta-info id category kind type-spec type-checker
124 validate-function default
)))))
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
*)))
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
)))))
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))
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?
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.
193 (or alien-type null
) (or heap-alien-info null
))
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
)
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"
247 (with-globaldb-name (key1 key2
) name
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
))
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)
263 ;; if -REMOVE => nil, then update NEW but return OLD
264 (or (setq new
(packed-info-remove
265 old
+no-auxilliary-key
+ info-numbers
))
267 (info-puthash *info-environment
* name
#'clear-hairy
)))
270 ;;;; *INFO-ENVIRONMENT*
273 (setq *info-environment
* (make-info-hashtable))
274 (/show0
"done setting *INFO-ENVIRONMENT*"))
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
))
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
+)))
305 (let ((index (packed-info-value-index vector aux-key info-number
)))
307 (let ((answer (svref vector index
)))
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
)))
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
)
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
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
)
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
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)
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.
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
417 (define-info-type (:function
:where-from
)
418 :type-spec
(member :declared
:defined-method
:assumed
:defined
)
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
)
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
))
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
)
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)
532 (declare (symbol symbol
))
533 (and (eq (info :variable
:kind symbol
) :special
)
535 (eq (symbol-package symbol
) *cl-package
*)
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
))
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")))
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
))
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
))
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
)))
629 (error 'simple-type-error
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
)
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
))
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
)
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)
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
)
737 (list (meta-info-category type
) (meta-info-kind type
))))
738 (write val
:level
1)))
741 (!defun-from-collected-cold-init-forms
!globaldb-cold-init
)