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 (!begin-collecting-cold-init-forms
)
38 #!+sb-show
(!cold-init-forms
(/show0
"early in globaldb.lisp cold init"))
40 ;;; This is sorta semantically equivalent to SXHASH, but better-behaved for
41 ;;; legal function names. It performs more work by not cutting off as soon
42 ;;; in the CDR direction, thereby improving the distribution of method names.
43 ;;; More work here equates to less work in the global hashtable.
44 ;;; To wit: (eq (sxhash '(foo a b c bar)) (sxhash '(foo a b c d))) => T
45 ;;; but the corresponding globaldb-sxhashoids differ.
46 ;;; This is no longer inline because for the cases where it is needed -
47 ;;; names which are not just symbols or (SETF F) - an extra call has no impact.
48 (defun globaldb-sxhashoid (name)
49 ;; we can't use MIX because it's in 'target-sxhash',
50 ;; so use the host's sxhash, but ensure that the result is a target fixnum.
51 #+sb-xc-host
(logand (sxhash name
) sb
!xc
:most-positive-fixnum
)
54 (declare (optimize (safety 0))) ; after the argc check
55 ;; TRAVERSE will walk across more cons cells than RECURSE will descend.
56 ;; That's why this isn't just one self-recursive function.
57 (labels ((traverse (accumulator x length-limit
)
58 (declare (fixnum length-limit
))
59 (cond ((atom x
) (sb!int
:mix
(sxhash x
) accumulator
))
60 ((zerop length-limit
) accumulator
)
61 (t (traverse (sb!int
:mix
(recurse (car x
) 4) accumulator
)
62 (cdr x
) (1- length-limit
)))))
63 (recurse (x depthoid
) ; depthoid = a blend of level and length
64 (declare (fixnum depthoid
))
65 (cond ((atom x
) (sxhash x
))
67 #.
(logand sb
!xc
:most-positive-fixnum
#36Rglobaldbsxhashoid
))
68 (t (sb!int
:mix
(recurse (car x
) (1- depthoid
))
69 (recurse (cdr x
) (1- depthoid
)))))))
70 (traverse 0 name
10))))
72 ;;; Given any non-negative integer, return a prime number >= to it.
74 ;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
75 ;;; hash-table.lisp. Perhaps the merged logic should be
76 ;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
77 ;;; after integral powers of two:
78 ;;; #(17 37 67 131 ..)
79 ;;; (Or, if that's too coarse, after half-integral powers of two.) By
80 ;;; thus getting rid of any need for primality testing at runtime, we
81 ;;; could punt POSITIVE-PRIMEP, too.
83 (declare (type unsigned-byte x
))
84 (do ((n (logior x
1) (+ n
2)))
85 ((positive-primep n
) n
)))
87 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
88 ;;; running the cross-compiler? The cross-compiler (which was built
89 ;;; from these sources) has its version of these data and functions
90 ;;; defined in the same places we'd be defining into. We're happy with
91 ;;; its version, since it was compiled from the same sources, so
92 ;;; there's no point in overwriting its nice compiled version of this
93 ;;; stuff with our interpreted version. (And any time we're *not*
94 ;;; happy with its version, perhaps because we've been editing the
95 ;;; sources partway through bootstrapping, tch tch, overwriting its
96 ;;; version with our version would be unlikely to help, because that
97 ;;; would make the cross-compiler very confused.)
98 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
100 ;;; A map from info-number to its META-INFO object.
101 ;;; The reverse mapping is obtained by reading the META-INFO.
102 (declaim (type (simple-vector #.
(ash 1 info-number-bits
)) *info-types
*))
103 (!defglobal
*info-types
*
104 (make-array (ash 1 info-number-bits
) :initial-element nil
))
106 (def!struct
(meta-info
107 #-no-ansi-print-object
108 (:print-object
(lambda (x s
)
109 (print-unreadable-object (x s
)
112 (meta-info-category x
)
114 (meta-info-number x
)))))
116 !make-meta-info
(number category kind type-spec
117 type-checker validate-function default
))
119 ;; a number that uniquely identifies this object
120 (number nil
:type info-number
:read-only t
)
121 ;; 2-part key to this piece of metainfo
122 (category nil
:type keyword
:read-only t
)
123 (kind nil
:type keyword
:read-only t
)
124 ;; a type specifier which info of this type must satisfy
125 (type-spec nil
:type t
:read-only t
)
126 ;; Two functions called by (SETF INFO) before calling SET-INFO-VALUE.
127 ;; 1. A function that type-checks its argument and returns it,
128 ;; or signals an error.
129 ;; Some Lisps trip over their shoelaces trying to assert that
130 ;; a function is (function (t) t). Our code is fine though.
131 (type-checker nil
:type
#+sb-xc-host function
#-sb-xc-host
(sfunction (t) t
)
133 ;; 2. a function of two arguments, a name and new-value, which performs
134 ;; any other checks and/or side-effects including signaling an error.
135 (validate-function nil
:type
(or function null
) :read-only t
)
136 ;; If FUNCTIONP, then a function called when there is no information of
137 ;; this type. If not FUNCTIONP, then any object serving as a default.
138 (default nil
)) ; shoud be :read-only t. I have a fix for that.
140 (declaim (freeze-type meta-info
))
142 (defconstant +info-metainfo-type-num
+ 0)
144 ;; Perform the equivalent of (GET-INFO-VALUE sym +INFO-METAINFO-TYPE-NUM+)
145 ;; but without the AVER that meta-info for +info-metainfo-type-num+ exists,
146 ;; and bypassing the defaulting logic, returning zero or more META-INFOs that
147 ;; match KIND based on half of their key, which is often a unique
148 ;; identifier by itself.
149 (defmacro !get-meta-infos
(kind)
150 `(let* ((info-vector (symbol-info-vector ,kind
))
151 (index (if info-vector
152 (packed-info-value-index info-vector
+no-auxilliary-key
+
153 +info-metainfo-type-num
+))))
154 (if index
(svref info-vector index
))))
156 ;; really this takes (KEYWORD KEYWORD) but SYMBOL is easier to test,
157 ;; and "or lose" is an explicit check anyway.
158 (declaim (ftype (function (symbol symbol
) meta-info
) meta-info-or-lose
))
159 (defun meta-info-or-lose (category kind
)
160 ;; Usually KIND designates a unique object, so we store only that object.
161 ;; Otherwise we store a list which has a small (<= 4) handful of items.
162 (or (let ((metadata (!get-meta-infos kind
)))
163 (cond ((listp metadata
)
164 (dolist (info metadata nil
) ; FIND is slower :-(
165 (when (eq (meta-info-category (truly-the meta-info info
))
168 ((eq (meta-info-category (truly-the meta-info metadata
)) category
)
170 (error "(~S ~S) is not a defined info type." category kind
)))
172 (defun !register-meta-info
(metainfo)
173 (let* ((name (meta-info-kind metainfo
))
174 (list (!get-meta-infos name
)))
175 (set-info-value name
+info-metainfo-type-num
+
176 (cond ((not list
) metainfo
) ; unique, just store it
177 ((listp list
) (cons metainfo list
)) ; prepend to the list
178 (t (list metainfo list
)))))) ; convert atom to a list
180 (defun !%define-info-type
(category kind type-spec type-checker
181 validate-function default
&optional id
)
182 (awhen (ignore-errors (meta-info-or-lose category kind
)) ; if found
184 (aver (= (meta-info-number it
) id
)))
185 (return-from !%define-info-type it
)) ; do nothing
186 (let ((id (or id
(position nil
*info-types
* :start
1)
187 (error "no more INFO type numbers available"))))
189 (setf (aref *info-types
* id
)
190 (!make-meta-info id category kind type-spec type-checker
191 validate-function default
)))))
196 (setf (get '!%define-info-type
:sb-cold-funcall-handler
)
197 (lambda (category kind type-spec checker validator default id
)
198 ;; The SB!FASL: symbols are poor style, but the lesser evil.
199 ;; If exported, then they'll stick around in the target image.
200 ;; Perhaps SB-COLD should re-export some of these.
201 (declare (special sb
!fasl
::*dynamic
* sb
!fasl
::*cold-layouts
*))
202 (let ((layout (gethash 'meta-info sb
!fasl
::*cold-layouts
*)))
204 (sb!fasl
::cold-symbol-value
'*info-types
*)
206 (sb!fasl
::write-slots
207 (sb!fasl
::allocate-struct sb
!fasl
::*dynamic
* layout
)
208 (find-layout 'meta-info
)
209 :category category
:kind kind
:type-spec type-spec
210 :type-checker checker
:validate-function validator
211 :default default
:number id
)))))
214 (dovector (x (the simple-vector
*info-types
*))
215 ;; Genesis writes the *INFO-TYPES* array, but setting up the mapping
216 ;; from keyword-pair to object is deferred until cold-init.
217 (when x
(!register-meta-info x
))))
219 ;;;; info types, and type numbers, part II: what's
220 ;;;; needed only at compile time, not at run time
222 ;;; Define a new type of global information.
223 ;;; CATEGORY/KIND form a two-part name for the piece of information,
224 ;;; DEFAULT is a defaulting expression, and TYPE-SPEC
225 ;;; is a type specifier which data values must satisfy.
226 ;;; Roughly speaking there is a hierarchy to the two-piece names
227 ;;; but this is a fiction that is not maintained anywhere in the internals.
229 ;;; If the defaulting expression's value is a function, it is called with
230 ;;; the name for which the information is being looked up; otherwise it is
231 ;;; taken as the default value. The defaulting expression is used each time
232 ;;; a value is needed when one hasn't been previously set. (The result
233 ;;; does not automatically become the new value for the piece of info.)
234 ;;; Should a default value be itself a function, this must be expressed as
235 ;;; :DEFAULT (CONSTANTLY #'<a-function-name>) to adhere to the convention
236 ;;; that default objects satisfying FUNCTIONP will always be funcalled.
238 (eval-when (:compile-toplevel
:execute
)
239 ;; This convoluted idiom creates a macro that disappears from the target,
240 ;; kind of an alternative to the "!" name convention.
241 (#+sb-xc-host defmacro
242 #-sb-xc-host sb
!xc
:defmacro
243 define-info-type
((category kind
)
244 &key
(type-spec (missing-arg))
247 (declare (type keyword category kind
))
248 ;; There was formerly a remark that (COPY-TREE TYPE-SPEC) ensures repeatable
249 ;; fasls. That's not true now, probably never was. A compiler is permitted to
250 ;; coalesce EQUAL quoted lists and there's no defense against it, so why try?
252 `(!%define-info-type
,category
,kind
',type-spec
253 ,(if (eq type-spec
't
) '#'identity
`(lambda (x) (the ,type-spec x
)))
254 ,validate-function
,default
255 ;; Rationale for hardcoding here is explained at INFO-VECTOR-FDEFN.
256 ,(or (and (eq category
:function
) (eq kind
:definition
)
258 #+sb-xc
(meta-info-number (meta-info-or-lose category kind
))))))
259 `(eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
) ,form
))))
262 ;;; INFO is the standard way to access the database. It's settable.
264 ;;; Return the information of the specified CATEGORY and KIND for NAME.
265 ;;; The second value returned is true if there is any such information
266 ;;; recorded. If there is no information, the first value returned is
267 ;;; the default and the second value returned is NIL.
268 (defun info (category kind name
)
269 (let ((info (meta-info-or-lose category kind
)))
270 (get-info-value name
(meta-info-number info
))))
272 (defun (setf info
) (new-value category kind name
)
273 (let ((info (meta-info-or-lose category kind
)))
274 (funcall (meta-info-type-checker info
) new-value
)
275 (awhen (meta-info-validate-function info
)
276 (funcall it name new-value
))
277 (set-info-value name
(meta-info-number info
) new-value
)))
279 ;;; Clear the information of the specified CATEGORY and KIND for NAME in
280 ;;; the current environment. Return true if there was any info.
281 (defun clear-info (category kind name
)
282 (let* ((info (meta-info-or-lose category kind
))
283 (info-number-list (list (meta-info-number info
))))
284 (declare (dynamic-extent info-number-list
))
285 (clear-info-values name info-number-list
)))
287 (defun clear-info-values (name info-numbers
)
288 (dolist (type info-numbers
)
289 (aver (and (typep type
'info-number
) (svref *info-types
* type
))))
290 ;; A call to UNCROSS was suspiciously absent, so I added this ERROR
291 ;; to be certain that it's not supposed to happen when building the xc.
292 #+sb-xc-xhost
(error "Strange CLEAR-INFO building the xc: ~S ~S"
295 (with-globaldb-name (key1 key2
) name
297 ;; If PACKED-INFO-REMOVE has nothing to do, it returns NIL,
298 ;; corresponding to the input that UPDATE-SYMBOL-INFO expects.
299 (dx-flet ((clear-simple (old)
300 (setq new
(packed-info-remove old key2 info-numbers
))))
301 (update-symbol-info key1
#'clear-simple
))
303 ;; The global hashtable is not imbued with knowledge of the convention
304 ;; for PACKED-INFO-REMOVE because that would render it less useful
305 ;; as a general-purpose global hashtable for other kinds of stuff
306 ;; that I might want it to store aside from packed infos.
307 ;; So here UPDATE might receive NIL but must not return NIL if
308 ;; there was a non-nil input. NIL doesn't mean "do nothing".
309 (dx-flet ((clear-hairy (old)
311 ;; if -REMOVE => nil, then update NEW but return OLD
312 (or (setq new
(packed-info-remove
313 old
+no-auxilliary-key
+ info-numbers
))
315 (info-puthash *info-environment
* name
#'clear-hairy
)))
318 ;;;; *INFO-ENVIRONMENT*
321 (setq *info-environment
* (make-info-hashtable))
322 (/show0
"done setting *INFO-ENVIRONMENT*"))
326 ;;; Return the value of NAME / INFO-NUMBER from the global environment,
327 ;;; or return the default if there is no global info.
328 ;;; The secondary value indicates whether info was found vs defaulted.
329 (declaim (ftype (sfunction (t info-number
) (values t boolean
))
331 (defun get-info-value (name info-number
)
332 (multiple-value-bind (vector aux-key
)
333 (let ((name (uncross name
)))
334 (with-globaldb-name (key1 key2
) name
335 :simple
(values (symbol-info-vector key1
) key2
)
336 :hairy
(values (info-gethash name
*info-environment
*)
337 +no-auxilliary-key
+)))
340 (packed-info-value-index vector aux-key info-number
)))
342 (return-from get-info-value
(values (svref vector index
) t
))))))
343 (let ((val (meta-info-default (aref *info-types
* info-number
))))
344 (values (if (functionp val
) (funcall val name
) val
) nil
)))
346 ;; Perform the approximate equivalent operations of retrieving
347 ;; (INFO :CATEGORY :KIND NAME), but if no info is found, invoke CREATION-FORM
348 ;; to produce an object that becomes the value for that piece of info, storing
349 ;; and returning it. The entire sequence behaves atomically but with a proviso:
350 ;; the creation form's result may be discarded, and another object returned
351 ;; instead (presumably) from another thread's execution of the creation form.
352 ;; If constructing the object has either non-trivial cost, or deleterious
353 ;; side-effects from making and discarding its result, do NOT use this macro.
354 ;; A mutex-guarded table would probably be more appropriate in such cases.
356 (def!macro get-info-value-initializing
(category kind name creation-form
)
357 (with-unique-names (info-number proc
)
359 ,(if (and (keywordp category
) (keywordp kind
))
360 (meta-info-number (meta-info-or-lose category kind
))
361 `(meta-info-number (meta-info-or-lose ,category
,kind
)))))
362 (dx-flet ((,proc
() ,creation-form
))
363 (%get-info-value-initializing
,name
,info-number
#',proc
)))))
365 ;; interface to %ATOMIC-SET-INFO-VALUE
366 ;; GET-INFO-VALUE-INITIALIZING is a restricted case of this,
367 ;; and perhaps could be implemented as such.
368 ;; Atomic update will be important for making the fasloader threadsafe
369 ;; using a predominantly lock-free design, and other nice things.
370 (def!macro atomic-set-info-value
(category kind name lambda
)
371 (with-unique-names (info-number proc
)
373 ,(if (and (keywordp category
) (keywordp kind
))
374 (meta-info-number (meta-info-or-lose category kind
))
375 `(meta-info-number (meta-info-or-lose ,category
,kind
)))))
376 ,(if (and (listp lambda
) (eq (car lambda
) 'lambda
))
377 ;; rewrite as FLET because the compiler is unable to dxify
378 ;; (DX-LET ((x (LAMBDA <whatever>))) (F x))
379 (destructuring-bind (lambda-list . body
) (cdr lambda
)
380 `(dx-flet ((,proc
,lambda-list
,@body
))
381 (%atomic-set-info-value
,name
,info-number
#',proc
)))
382 `(%atomic-set-info-value
,name
,info-number
,lambda
)))))
384 ;; Call FUNCTION once for each Name in globaldb that has information associated
385 ;; with it, passing the function the Name as its only argument.
387 (defun call-with-each-globaldb-name (fun-designator)
388 (let ((function (coerce fun-designator
'function
)))
389 (with-package-iterator (iter (list-all-packages) :internal
:external
)
390 (loop (multiple-value-bind (winp symbol access package
) (iter)
391 (declare (ignore access
))
392 (if (not winp
) (return))
393 ;; Try to process each symbol at most once by associating it with
394 ;; a single package. If a symbol is apparently uninterned,
395 ;; always keep it since we can't know if it has been seen once.
396 (when (or (not (symbol-package symbol
))
397 (eq package
(symbol-package symbol
)))
398 (dolist (name (info-vector-name-list symbol
))
399 (funcall function name
))))))
400 (info-maphash (lambda (name data
)
401 (declare (ignore data
))
402 (funcall function name
))
403 *info-environment
*)))
405 ;;;; ":FUNCTION" subsection - Data pertaining to globally known functions.
407 (define-info-type (:function
:definition
) :type-spec
(or fdefn null
))
409 ;;; the kind of functional object being described. If null, NAME isn't
410 ;;; a known functional object.
411 (define-info-type (:function
:kind
)
412 :type-spec
(member nil
:function
:macro
:special-form
)
413 ;; I'm a little confused what the correct behavior of this default
414 ;; is. It's not clear how to generalize the FBOUNDP expression to
415 ;; the cross-compiler. As far as I can tell, NIL is a safe default
416 ;; -- it might keep the compiler from making some valid
417 ;; optimization, but it shouldn't produce incorrect code. -- WHN
421 #-sb-xc-host
(lambda (name) (if (fboundp name
) :function nil
)))
423 ;;; The type specifier for this function.
424 (define-info-type (:function
:type
)
426 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's
427 ;; not clear how to generalize the FBOUNDP expression to the
428 ;; cross-compiler. -- WHN 19990330
430 ;; Delay evaluation of (SPECIFIER-TYPE) since it can't work yet
431 #+sb-xc-host
(lambda (x) (declare (ignore x
)) (specifier-type 'function
))
432 #-sb-xc-host
(lambda (name)
434 (handler-bind ((style-warning #'muffle-warning
))
435 (specifier-type (sb!impl
::%fun-type
(fdefinition name
))))
436 (specifier-type 'function
))))
438 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
439 ;;; due to not having a declaration or definition
440 (define-info-type (:function
:assumed-type
)
441 ;; FIXME: The type-spec really should be
442 ;; (or approximate-fun-type null)).
443 ;; It was changed to T as a hopefully-temporary hack while getting
444 ;; cold init problems untangled.
447 ;;; where this information came from:
448 ;;; :ASSUMED = from uses of the object
449 ;;; :DEFINED = from examination of the definition
450 ;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
451 ;;; :DECLARED = from a declaration
452 ;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
453 ;;; and :DECLARED trumps :DEFINED-METHOD.
454 ;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
455 ;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
456 ;;; code which implements the function, or which uses the function's
458 (define-info-type (:function
:where-from
)
459 :type-spec
(member :declared
:defined-method
:assumed
:defined
)
461 ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :KIND) ...)] it's
462 ;; not clear how to generalize the FBOUNDP expression to the
463 ;; cross-compiler. -- WHN 19990606
464 #+sb-xc-host
:assumed
465 #-sb-xc-host
(lambda (name) (if (fboundp name
) :defined
:assumed
)))
467 ;;; something which can be decoded into the inline expansion of the
468 ;;; function, or NIL if there is none
470 ;;; To inline a function, we want a lambda expression, e.g.
471 ;;; '(LAMBDA (X) (+ X 1)).
472 (define-info-type (:function
:inline-expansion-designator
)
475 ;;; This specifies whether this function may be expanded inline. If
476 ;;; null, we don't care.
477 (define-info-type (:function
:inlinep
) :type-spec inlinep
)
479 ;;; Track how many times IR2 converted a call to this function as a full call
480 ;;; that was not in the scope of a local or global notinline declaration.
481 ;;; Useful for finding functions that were supposed to have been converted
482 ;;; through some kind of transformation but were not.
483 (define-info-type (:function
:emitted-full-calls
) :type-spec list
)
485 ;;; a macro-like function which transforms a call to this function
486 ;;; into some other Lisp form. This expansion is inhibited if inline
487 ;;; expansion is inhibited.
488 ;;; As an exception, a cons of two atoms represents structure metadata
489 ;;; which is recognized and transformed in a stylized way.
490 (define-info-type (:function
:source-transform
)
491 :type-spec
(or function null
(cons atom atom
)))
493 ;;; the macroexpansion function for this macro
494 (define-info-type (:function
:macro-function
) :type-spec
(or function null
))
496 ;;; the compiler-macroexpansion function for this function or macro
497 (define-info-type (:function
:compiler-macro-function
)
498 :type-spec
(or function null
))
500 ;;; a function which converts this special form into IR1
501 (define-info-type (:function
:ir1-convert
) :type-spec
(or function null
))
503 ;;; If a function is "known" to the compiler, then this is a FUN-INFO
504 ;;; structure containing the info used to special-case compilation.
505 (define-info-type (:function
:info
) :type-spec
(or fun-info null
))
508 ;;;; ":VARIABLE" subsection - Data pertaining to globally known variables.
510 ;;; the kind of variable-like thing described
511 (define-info-type (:variable
:kind
)
512 :type-spec
(member :special
:constant
:macro
:global
:alien
:unknown
)
513 :default
(lambda (name)
514 (if (typep name
'(or boolean keyword
))
518 (define-info-type (:variable
:always-bound
)
519 :type-spec
(member nil
:eventually
:always-bound
))
521 (define-info-type (:variable
:deprecated
) :type-spec t
)
523 ;;; the declared type for this variable
524 (define-info-type (:variable
:type
)
526 ;; This gets set to *UNIVERSAL-TYPE* in 'late-type'
527 :default
(lambda (x) (declare (ignore x
)) (error "Too early for INFO")))
529 ;;; where this type and kind information came from
530 (define-info-type (:variable
:where-from
)
531 :type-spec
(member :declared
:assumed
:defined
) :default
:assumed
)
533 ;;; the macro-expansion for symbol-macros
534 (define-info-type (:variable
:macro-expansion
) :type-spec t
)
536 (define-info-type (:variable
:alien-info
)
537 :type-spec
(or heap-alien-info null
))
539 (define-info-type (:variable
:documentation
) :type-spec
(or string null
))
541 ;; :WIRED-TLS describes how SYMBOL-VALUE (implicit or not) should be compiled.
542 ;; - :ALWAYS-HAS-TLS means that calls to SYMBOL-VALUE should access the TLS
543 ;; with a fixed offset. The index is assigned no later than load-time of
544 ;; the file containing code thus compiled. Presence of an index in the
545 ;; image that performed compilation is irrelevant (for now).
546 ;; - :ALWAYS-THREAD-LOCAL implies a fixed offset, *and* that the check for
547 ;; no-tls-value may be elided. There is currently no way to set this.
548 ;; Note that this does not affect elision of the check for unbound-marker
549 ;; which is under control of the :ALWAYS-BOUND info.
550 ;; - an integer is a permanent index, and also implies :ALWAYS-THREAD-LOCAL.
551 ;; Specials in the CL package (notably reader/printer controls) use a wired-tls,
552 ;; whether or not we bind per-thread [if we don't, that's a bug!]
553 ;; We don't assume wired TLS more generally, because user code often defines
554 ;; thousands of DEFVARs, possibly due to poor style, or due to ANSI's stance
555 ;; that DEFCONSTANT is only for EQL-comparable objects. In such cases with
556 ;; more symbols than can be bound per-thread, the compiler won't exacerbate
557 ;; things by making the loader eagerly assign a TLS index to every symbol
558 ;; ever referenced by SYMBOL-VALUE or SET. Depletion should occur lazily.
560 (define-info-type (:variable
:wired-tls
)
561 :type-spec
(or (member nil
:always-has-tls
:always-thread-local
)
562 fixnum
) ; the actual index, for thread slots (to be done)
565 (declare (symbol symbol
))
566 (and (eq (info :variable
:kind symbol
) :special
)
568 (eq (symbol-package symbol
) *cl-package
*)
570 (flet ((external-in-package-p (pkg)
571 (and (string= (package-name (symbol-package symbol
)) pkg
)
572 (eq (nth-value 1 (find-symbol (string symbol
) pkg
))
574 ;; I'm not worried about random extra externals in some bizarro
575 ;; host lisp. TLS assignment has no bearing on semantics at all.
576 (or (external-in-package-p "COMMON-LISP")
577 (external-in-package-p "SB-XC")))
580 ;;;; ":TYPE" subsection - Data pertaining to globally known types.
582 ;;; the kind of type described. We return :INSTANCE for standard types
583 ;;; that are implemented as structures. For PCL classes, that have
584 ;;; only been compiled, but not loaded yet, we return
585 ;;; :FORTHCOMING-DEFCLASS-TYPE.
586 ;;; The only major distinction between :PRIMITIVE and :DEFINED
587 ;;; is how badly the system complains about attempted redefinition.
588 (define-info-type (:type
:kind
)
589 :type-spec
(member :primitive
:defined
:instance
590 :forthcoming-defclass-type nil
)
591 :validate-function
(lambda (name new-value
)
592 (declare (ignore new-value
))
593 (when (info :declaration
:recognized name
)
594 (error 'declaration-type-conflict-error
595 :format-arguments
(list name
)))))
597 (define-info-type (:type
:documentation
) :type-spec
(or string null
))
599 ;;; The expander function for a defined type.
600 ;;; It returns a type expression, not a CTYPE.
601 (define-info-type (:type
:expander
)
602 :type-spec
(or function null
)
603 ;; This error is never seen by a user.
604 ;; The user sees "illegal to redefine standard type".
605 :validate-function
(lambda (name new-value
)
606 (when (and new-value
(info :type
:translator name
))
607 (bug "Type has a translator"))))
609 ;;; Either a CTYPE which is the translation of this type name,
610 ;;; or a function that parses type specifiers into CTYPE structures.
611 ;;; The :BUILTIN property is mutually exclusive with a CTYPE stored here.
612 ;;; :BUILTIN could probably be eliminated, as it is redundant since we
613 ;;; can discern a :BUILTIN by its :KIND being :PRIMITIVE.
614 (define-info-type (:type
:translator
)
615 :type-spec
(or function ctype null
)
616 ;; This error is never seen by a user. After meta-compile there is no
617 ;; means to define additional types with custom translators.
618 :validate-function
(lambda (name new-value
)
619 (when (and new-value
(info :type
:expander name
))
620 (bug "Type has an expander"))
621 (when (and (not (functionp new-value
))
623 (info :type
:builtin name
))
624 (bug ":BUILTIN and :TRANSLATOR are incompatible"))))
626 ;;; If true, then the type coresponding to this name. Note that if
627 ;;; this is a built-in class with a translation, then this is the
628 ;;; translation, not the class object. This info type keeps track of
629 ;;; various atomic types (NIL etc.) and also serves as a means to
630 ;;; ensure that common standard types are only consed once.
631 (define-info-type (:type
:builtin
)
632 :type-spec
(or ctype null
)
633 :validate-function
(lambda (name new-value
)
634 (when (and (ctype-p new-value
)
635 (ctype-p (info :type
:translator name
)))
636 (bug ":BUILTIN and :TRANSLATOR are incompatible"))))
638 ;;; The classoid-cell for this type
639 (define-info-type (:type
:classoid-cell
) :type-spec t
)
641 ;;; layout for this type being used by the compiler
642 (define-info-type (:type
:compiler-layout
)
643 :type-spec
(or layout null
)
644 :default
(lambda (name)
645 (let ((class (find-classoid name nil
)))
646 (when class
(classoid-layout class
)))))
648 ;;; DEFTYPE lambda-list
649 ;; FIXME: remove this after making swank-fancy-inspector not use it.
650 (define-info-type (:type
:lambda-list
) :type-spec nil
)
652 (define-info-type (:type
:source-location
) :type-spec t
)
654 ;;;; ":TYPED-STRUCTURE" subsection.
655 ;;;; Data pertaining to structures that used DEFSTRUCT's :TYPE option.
656 (define-info-type (:typed-structure
:info
) :type-spec t
)
657 (define-info-type (:typed-structure
:documentation
) :type-spec
(or string null
))
659 ;;;; ":DECLARATION" subsection - Data pertaining to user-defined declarations.
660 ;; CLTL2 offers an API to provide a list of known declarations, but it is
661 ;; inefficient to iterate over all symbols to find ones which have the
662 ;; (:DECLARATION :RECOGNIZED) info.
663 ;; Therefore maintain a list of recognized declarations. This list makes the
664 ;; globaldb storage of same redundant, but oh well.
665 (defglobal *recognized-declarations
* nil
)
666 (define-info-type (:declaration
:recognized
)
668 ;; There's no portable way to unproclaim that a symbol is a declaration,
669 ;; but at the low-level permit new-value to be NIL.
670 :validate-function
(lambda (name new-value
)
671 (declare (symbol name
))
673 (when (info :type
:kind name
)
674 (error 'declaration-type-conflict-error
675 :format-arguments
(list name
)))
676 (pushnew name
*recognized-declarations
*))
678 (setq *recognized-declarations
*
679 (delete name
*recognized-declarations
*))))))
681 (define-info-type (:declaration
:handler
) :type-spec
(or function null
))
683 ;;;; ":ALIEN-TYPE" subsection - Data pertaining to globally known alien-types.
684 (define-info-type (:alien-type
:kind
)
685 :type-spec
(member :primitive
:defined
:unknown
)
687 (define-info-type (:alien-type
:translator
) :type-spec
(or function null
))
688 (define-info-type (:alien-type
:definition
) :type-spec
(or alien-type null
))
689 (define-info-type (:alien-type
:struct
) :type-spec
(or alien-type null
))
690 (define-info-type (:alien-type
:union
) :type-spec
(or alien-type null
))
691 (define-info-type (:alien-type
:enum
) :type-spec
(or alien-type null
))
693 ;;;; ":SETF" subsection - Data pertaining to expansion of the omnipotent macro.
694 (define-info-type (:setf
:inverse
) :type-spec
(or symbol null
))
695 (define-info-type (:setf
:documentation
) :type-spec
(or string null
))
696 (define-info-type (:setf
:expander
) :type-spec
(or function null
))
698 ;;;; ":CAS" subsection - Like SETF but there are no "inverses", just expanders
699 (define-info-type (:cas
:expander
) :type-spec
(or function null
))
701 ;;;; ":RANDOM-DOCUMENTATION" subsection.
702 ;;; This is used for storing miscellaneous documentation types. The
703 ;;; stuff is an alist translating documentation kinds to values.
704 (define-info-type (:random-documentation
:stuff
) :type-spec list
)
706 ;;;; ":SOURCE-LOCATION" subsection.
707 ;;; This is kind of the opposite of what I'd have thought more logical,
708 ;;; where each of the above categories has one of its kinds of information
709 ;;; being :SOURCE-LOCATION.
710 ;;; And in fact that *is* how :TYPE was handled. However, many global entities
711 ;;; store their source-location hanging off some other hook, avoiding the
712 ;;; globaldb entirely, such as functions using a #<code-component>.
713 ;;; So either way is basically a hodgepodge.
715 (define-info-type (:source-location
:variable
) :type-spec t
)
716 (define-info-type (:source-location
:constant
) :type-spec t
)
717 (define-info-type (:source-location
:typed-structure
) :type-spec t
)
718 (define-info-type (:source-location
:symbol-macro
) :type-spec t
)
720 ;; This is for the SB-INTROSPECT contrib module, and debugging.
721 (defun call-with-each-info (function symbol
)
722 (awhen (symbol-info-vector symbol
)
723 (%call-with-each-info function it symbol
)))
725 ;; This is for debugging at the REPL.
726 (defun show-info (sym)
729 (lambda (name type-num val
)
730 (unless (eq name prev
)
731 (format t
"~&~S" (setq prev name
)))
732 (let ((type (svref *info-types
* type-num
)))
733 (format t
"~& ~@[type ~D~]~@[~{~S ~S~}~] = "
734 (if (not type
) type-num
)
736 (list (meta-info-category type
) (meta-info-kind type
))))
737 (write val
:level
1)))
740 ;;; Source transforms / compiler macros for INFO functions.
742 ;;; When building the XC, we give it a source transform, so that it can
743 ;;; compile INFO calls in the target efficiently; we also give it a compiler
744 ;;; macro, so that at least those INFO calls compiled after this file can be
745 ;;; efficient. (Host compiler-macros do not fire when compiling the target,
746 ;;; and source transforms don't fire when building the XC, so we need both.)
748 ;;; Target needs just one, since there compiler macros and source-transforms
750 (macrolet ((def (name lambda-list form
)
751 (aver (member 'category lambda-list
))
752 (aver (member 'kind lambda-list
))
754 ;; FIXME: instead of a macro and a transform, just define the macro
755 ;; early enough for both host and target compilation to see.
757 (define-source-transform ,name
,lambda-list
758 (if (and (keywordp category
) (keywordp kind
))
761 (define-compiler-macro ,name
,(append '(&whole .whole.
) lambda-list
)
762 (if (and (keywordp category
) (keywordp kind
))
766 (def info
(category kind name
)
767 (let ((info (meta-info-or-lose category kind
)))
768 `(truly-the (values ,(meta-info-type-spec info
) boolean
)
769 (get-info-value ,name
,(meta-info-number info
)))))
771 (def (setf info
) (new-value category kind name
)
772 (let* (#+sb-xc-host
(sb!xc
:*gensym-counter
* sb
!xc
:*gensym-counter
*)
773 (info (meta-info-or-lose category kind
))
774 (tin (meta-info-number info
))
775 (type-spec (meta-info-type-spec info
))
777 (when (meta-info-validate-function info
)
778 ;; is (or ... null), but non-null in host implies non-null
780 (meta-info-validate-function
781 (truly-the meta-info
(svref *info-types
* ,tin
)))))))
782 (with-unique-names (new)
783 `(let ((,new
,new-value
))
784 ;; enforce type-correctness regardless of enclosing policy
785 (let ((,new
(locally (declare (optimize (safety 3)))
786 (the ,type-spec
,new
))))
788 `((funcall ,check
,name
,new
)))
789 (set-info-value ,name
,tin
,new
))))))
791 (def clear-info
(category kind name
)
792 (let ((info (meta-info-or-lose category kind
)))
793 `(clear-info-values ,name
'(,(meta-info-number info
))))))
795 (!defun-from-collected-cold-init-forms
!globaldb-cold-init
)