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 ;;;; combination of Name, Class and Type. The Name is an EQUAL-thing
10 ;;;; which is the name of the thing we are recording information
11 ;;;; about. Class is the kind of object involved. Typical classes are
12 ;;;; :FUNCTION, :VARIABLE, :TYPE, ... A Type names a particular piece
13 ;;;; of information within a given class. Class and Type are keywords,
14 ;;;; and are compared with EQ.
16 ;;;; The relation between this file and 'info-vectors' is that the
17 ;;;; latter provides a fundamental mechanism to create property-list-like
18 ;;;; things whose "indicators" are restricted to small integers
19 ;;;; and whose values are anything; whereas the globaldb provides the
20 ;;;; facility of looking up the properties by keyword, a/k/a Class+Type.
21 ;;;; The keyword regime is somewhat arbitrary because ultimately the
22 ;;;; pair of keywords just translates to a small integer, usually
23 ;;;; resolvable at compile-time for the most part.
25 ;;;; This software is part of the SBCL system. See the README file for
26 ;;;; more information.
28 ;;;; This software is derived from the CMU CL system, which was
29 ;;;; written at Carnegie Mellon University and released into the
30 ;;;; public domain. The software is in the public domain and is
31 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
32 ;;;; files for more information.
36 (!begin-collecting-cold-init-forms
)
37 #!+sb-show
(!cold-init-forms
(/show0
"early in globaldb.lisp cold init"))
39 ;;; This is sorta semantically equivalent to SXHASH, but better-behaved for
40 ;;; legal function names. It performs more work by not cutting off as soon
41 ;;; in the CDR direction, thereby improving the distribution of method names.
42 ;;; More work here equates to less work in the global hashtable.
43 ;;; To wit: (eq (sxhash '(foo a b c bar)) (sxhash '(foo a b c d))) => T
44 ;;; but the corresponding globaldb-sxhashoids differ.
45 ;;; This is no longer inline because for the cases where it is needed -
46 ;;; names which are not just symbols or (SETF F) - an extra call has no impact.
47 (defun globaldb-sxhashoid (name)
48 ;; we can't use MIX because it's in 'target-sxhash',
49 ;; so use the host's sxhash, but ensure that the result is a target fixnum.
50 #+sb-xc-host
(logand (sxhash name
) sb
!xc
:most-positive-fixnum
)
53 (declare (optimize (safety 0))) ; after the argc check
54 ;; TRAVERSE will walk across more cons cells than RECURSE will descend.
55 ;; That's why this isn't just one self-recursive function.
56 (labels ((traverse (accumulator x length-limit
)
57 (declare (fixnum length-limit
))
58 (cond ((atom x
) (sb!int
:mix
(sxhash x
) accumulator
))
59 ((zerop length-limit
) accumulator
)
60 (t (traverse (sb!int
:mix
(recurse (car x
) 4) accumulator
)
61 (cdr x
) (1- length-limit
)))))
62 (recurse (x depthoid
) ; depthoid = a blend of level and length
63 (declare (fixnum depthoid
))
64 (cond ((atom x
) (sxhash x
))
66 #.
(logand sb
!xc
:most-positive-fixnum
#36Rglobaldbsxhashoid
))
67 (t (sb!int
:mix
(recurse (car x
) (1- depthoid
))
68 (recurse (cdr x
) (1- depthoid
)))))))
69 (traverse 0 name
10))))
71 ;;; Given any non-negative integer, return a prime number >= to it.
73 ;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
74 ;;; hash-table.lisp. Perhaps the merged logic should be
75 ;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
76 ;;; after integral powers of two:
77 ;;; #(17 37 67 131 ..)
78 ;;; (Or, if that's too coarse, after half-integral powers of two.) By
79 ;;; thus getting rid of any need for primality testing at runtime, we
80 ;;; could punt POSITIVE-PRIMEP, too.
82 (declare (type unsigned-byte x
))
83 (do ((n (logior x
1) (+ n
2)))
84 ((positive-primep n
) n
)))
86 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
87 ;;; running the cross-compiler? The cross-compiler (which was built
88 ;;; from these sources) has its version of these data and functions
89 ;;; defined in the same places we'd be defining into. We're happy with
90 ;;; its version, since it was compiled from the same sources, so
91 ;;; there's no point in overwriting its nice compiled version of this
92 ;;; stuff with our interpreted version. (And any time we're *not*
93 ;;; happy with its version, perhaps because we've been editing the
94 ;;; sources partway through bootstrapping, tch tch, overwriting its
95 ;;; version with our version would be unlikely to help, because that
96 ;;; would make the cross-compiler very confused.)
97 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
99 ;;; a map from type numbers to TYPE-INFO objects. There is one type
100 ;;; number for each kind of info.
101 (declaim (type (simple-vector #.
(ash 1 info-number-bits
)) *info-types
*))
102 (!defglobal
*info-types
*
103 (make-array (ash 1 info-number-bits
) :initial-element nil
))
105 ;; FIXME: really unclear name. It's an INFO-TYPE, not a TYPE-INFO.
106 ;; But probably would be better as GLOBALDB-METAINFO or something.
107 (def!struct
(type-info
108 #-no-ansi-print-object
109 (:print-object
(lambda (x s
)
110 (print-unreadable-object (x s
)
115 (type-info-number x
)))))
117 !make-globaldb-info-metadata
118 (number class name type-spec
119 type-checker validate-function default
))
121 ;; a number that uniquely identifies this type (and implicitly its class)
122 (number nil
:type info-number
:read-only t
)
123 ;; 2-part key to this piece of metainfo
124 ;; FIXME: taxonomy by CLASS and TYPE is too confusing and overloaded.
125 ;; and "name" is just wrong as neither half alone is the name.
126 (class nil
:type keyword
:read-only t
)
127 (name nil
:type keyword
:read-only t
)
128 ;; a type specifier which info of this type must satisfy
129 (type-spec nil
:type t
:read-only t
)
130 ;; Two functions called by (SETF INFO) before calling SET-INFO-VALUE.
131 ;; 1. A function that type-checks its argument and returns it,
132 ;; or signals an error.
133 ;; Some Lisps trip over their shoelaces trying to assert that
134 ;; a function is (function (t) t). Our code is fine though.
135 (type-checker nil
:type
#+sb-xc-host function
#-sb-xc-host
(sfunction (t) t
)
137 ;; 2. a function of two arguments, a name and new-value, which performs
138 ;; any other checks and/or side-effects including signaling an error.
139 (validate-function nil
:type
(or function null
) :read-only t
)
140 ;; If FUNCTIONP, then a function called when there is no information of
141 ;; this type. If not FUNCTIONP, then any object serving as a default.
142 (default nil
)) ; shoud be :read-only t. I have a fix for that.
144 (declaim (freeze-type type-info
))
146 (defconstant +info-metainfo-type-num
+ 0)
148 ;; Perform the equivalent of (GET-INFO-VALUE sym +INFO-METAINFO-TYPE-NUM+)
149 ;; but without the AVER that metadata already exists, and bypassing the
151 (defmacro !get-type-info-metadata
(sym)
152 `(let* ((info-vector (symbol-info-vector ,sym
))
153 (index (if info-vector
154 (packed-info-value-index info-vector
+no-auxilliary-key
+
155 +info-metainfo-type-num
+))))
156 (if index
(svref info-vector index
))))
158 ;; really this takes (KEYWORD KEYWORD) but SYMBOL is easier to test,
159 ;; and "or lose" is an explicit check anyway.
160 (declaim (ftype (function (symbol symbol
) type-info
) type-info-or-lose
))
161 (defun type-info-or-lose (class type
)
162 ;; Usually TYPE designates a unique object, so we store only that object.
163 ;; Otherwise we store a list which has a small (<= 4) handful of items.
164 (or (let ((metadata (!get-type-info-metadata type
)))
165 (cond ((listp metadata
)
166 (dolist (info metadata nil
) ; FIND is slower :-(
167 (when (eq (type-info-class (truly-the type-info info
))
170 ((eq (type-info-class (truly-the type-info metadata
)) class
)
172 (error "(~S ~S) is not a defined info type." class type
)))
174 (defun !register-type-info
(metainfo)
175 (let* ((name (type-info-name metainfo
))
176 (list (!get-type-info-metadata name
)))
177 (set-info-value name
+info-metainfo-type-num
+
178 (cond ((not list
) metainfo
) ; unique, just store it
179 ((listp list
) (cons metainfo list
)) ; prepend to the list
180 (t (list metainfo list
)))))) ; convert atom to a list
182 (defun !%define-info-type
(class name type-spec type-checker
183 validate-function default
&optional id
)
184 (awhen (ignore-errors (type-info-or-lose class name
)) ; if found
186 (aver (= (type-info-number it
) id
)))
187 (return-from !%define-info-type it
)) ; do nothing
188 (let ((id (or id
(position nil
*info-types
* :start
1)
189 (error "no more INFO type numbers available"))))
191 (setf (aref *info-types
* id
)
192 (!make-globaldb-info-metadata id class name type-spec type-checker
193 validate-function default
)))))
198 (setf (get '!%define-info-type
:sb-cold-funcall-handler
)
199 (lambda (class name type-spec checker validator default id
)
200 ;; The SB!FASL: symbols are poor style, but the lesser evil.
201 ;; If exported, then they'll stick around in the target image.
202 ;; Perhaps SB-COLD should re-export some of these.
203 (declare (special sb
!fasl
::*dynamic
* sb
!fasl
::*cold-layouts
*))
204 (let ((layout (gethash 'type-info sb
!fasl
::*cold-layouts
*)))
206 (sb!fasl
::cold-symbol-value
'*info-types
*)
208 (sb!fasl
::write-slots
209 (sb!fasl
::allocate-struct sb
!fasl
::*dynamic
* layout
)
210 (find-layout 'type-info
)
211 :class class
:name name
:type-spec type-spec
212 :type-checker checker
:validate-function validator
213 :default default
:number id
)))))
216 (dovector (x (the simple-vector
*info-types
*))
217 ;; Genesis writes the *INFO-TYPES* array, but setting up the mapping
218 ;; from keyword-pair to object is deferred until cold-init.
219 (when x
(!register-type-info x
))))
221 ;;;; info types, and type numbers, part II: what's
222 ;;;; needed only at compile time, not at run time
224 ;;; Define a new type of global information.
225 ;;; CLASS/TYPE form a two-piece name for the kind of information,
226 ;;; DEFAULT is a defaulting expression, and TYPE-SPEC
227 ;;; is a type specifier which values of the type must satisfy.
228 ;;; Roughly speaking there is a hierarchy to the two-piece names
229 ;;; but this is a fiction that is not maintained anywhere in the internals.
231 ;;; If the defaulting expression's value is a function, it is called with
232 ;;; the name for which the information is being looked up; otherwise it is
233 ;;; taken as the default value. The defaulting expression is used each time
234 ;;; a value is needed when one hasn't been previously set. (The result
235 ;;; does not automatically become the new value for the piece of info.)
236 ;;; Should a default value be itself a function, this must be expressed as
237 ;;; :DEFAULT (CONSTANTLY #'<a-function-name>) to adhere to the convention
238 ;;; that default objects satisfying FUNCTIONP will always be funcalled.
240 (eval-when (:compile-toplevel
:execute
)
241 ;; This convoluted idiom creates a macro that disappears from the target,
242 ;; kind of an alternative to the "!" name convention.
243 (#+sb-xc-host defmacro
244 #-sb-xc-host sb
!xc
:defmacro
245 define-info-type
((class type
)
246 &key
(type-spec (missing-arg))
249 (declare (type keyword class type
))
250 ;; There was formerly a remark that (COPY-TREE TYPE-SPEC) ensures repeatable
251 ;; fasls. That's not true now, probably never was. A compiler is permitted to
252 ;; coalesce EQUAL quoted lists and there's no defense against it, so why try?
254 `(!%define-info-type
,class
,type
',type-spec
255 ,(if (eq type-spec
't
) '#'identity
`(lambda (x) (the ,type-spec x
)))
256 ,validate-function
,default
257 ;; Rationale for hardcoding here is explained at INFO-VECTOR-FDEFN.
258 ,(or (and (eq class
:function
) (eq type
:definition
) +fdefn-info-num
+)
259 #+sb-xc
(type-info-number (type-info-or-lose class type
))))))
260 `(eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
) ,form
))))
263 ;;; INFO is the standard way to access the database. It's settable.
265 ;;; Return the information of the specified TYPE and CLASS for NAME.
266 ;;; The second value returned is true if there is any such information
267 ;;; recorded. If there is no information, the first value returned is
268 ;;; the default and the second value returned is NIL.
269 (defun info (class type name
)
270 (let ((info (type-info-or-lose class type
)))
271 (get-info-value name
(type-info-number info
))))
273 (defun (setf info
) (new-value class type name
)
274 (let ((info (type-info-or-lose class type
)))
275 (funcall (type-info-type-checker info
) new-value
)
276 (awhen (type-info-validate-function info
)
277 (funcall it name new-value
))
278 (set-info-value name
(type-info-number info
) new-value
)))
280 ;;; Clear the information of the specified TYPE and CLASS for NAME in
281 ;;; the current environment. Return true if there was any info.
282 (defun clear-info (class type name
)
283 (let* ((info (type-info-or-lose class type
))
284 (info-number-list (list (type-info-number info
))))
285 (declare (dynamic-extent info-number-list
))
286 (clear-info-values name info-number-list
)))
288 (defun clear-info-values (name info-numbers
)
289 (dolist (type info-numbers
)
290 (aver (and (typep type
'info-number
) (svref *info-types
* type
))))
291 ;; A call to UNCROSS was suspiciously absent, so I added this ERROR
292 ;; to be certain that it's not supposed to happen when building the xc.
293 #+sb-xc-xhost
(error "Strange CLEAR-INFO building the xc: ~S ~S" name type
)
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 (type-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 :CLASS :TYPE 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
(info-class info-type name creation-form
)
357 (with-unique-names (info-number proc
)
359 ,(if (and (keywordp info-type
) (keywordp info-class
))
360 (type-info-number (type-info-or-lose info-class info-type
))
362 (type-info-or-lose ,info-class
,info-type
)))))
363 (dx-flet ((,proc
() ,creation-form
))
364 (%get-info-value-initializing
,name
,info-number
#',proc
)))))
366 ;; interface to %ATOMIC-SET-INFO-VALUE
367 ;; GET-INFO-VALUE-INITIALIZING is a restricted case of this,
368 ;; and perhaps could be implemented as such.
369 ;; Atomic update will be important for making the fasloader threadsafe
370 ;; using a predominantly lock-free design, and other nice things.
371 (def!macro atomic-set-info-value
(info-class info-type name lambda
)
372 (with-unique-names (info-number proc
)
374 ,(if (and (keywordp info-type
) (keywordp info-class
))
375 (type-info-number (type-info-or-lose info-class info-type
))
377 (type-info-or-lose ,info-class
,info-type
)))))
378 ,(if (and (listp lambda
) (eq (car lambda
) 'lambda
))
379 ;; rewrite as FLET because the compiler is unable to dxify
380 ;; (DX-LET ((x (LAMBDA <whatever>))) (F x))
381 (destructuring-bind (lambda-list . body
) (cdr lambda
)
382 `(dx-flet ((,proc
,lambda-list
,@body
))
383 (%atomic-set-info-value
,name
,info-number
#',proc
)))
384 `(%atomic-set-info-value
,name
,info-number
,lambda
)))))
386 ;; Call FUNCTION once for each Name in globaldb that has information associated
387 ;; with it, passing the function the Name as its only argument.
389 (defun call-with-each-globaldb-name (fun-designator)
390 (let ((function (coerce fun-designator
'function
)))
391 (dolist (package (list-all-packages))
392 (do-symbols (symbol package
)
393 (when (eq (symbol-package symbol
) package
)
394 (let ((vector (symbol-info-vector symbol
)))
396 ;; Check whether SYMBOL has info for itself
397 (when (plusp (packed-info-field vector
0 0))
398 (funcall function symbol
))
399 ;; Now deal with (<othersym> SYMBOL) names
400 (do-packed-info-vector-aux-key (vector key-index
)
402 (construct-globaldb-name (svref vector key-index
)
404 (info-maphash (lambda (name data
)
405 (declare (ignore data
))
406 (funcall function name
))
407 *info-environment
*)))
409 ;;;; ":FUNCTION" subsection - Data pertaining to globally known functions.
411 (define-info-type (:function
:definition
) :type-spec
(or fdefn null
))
413 ;;; the kind of functional object being described. If null, NAME isn't
414 ;;; a known functional object.
415 (define-info-type (:function
:kind
)
416 :type-spec
(member nil
:function
:macro
:special-form
)
417 ;; I'm a little confused what the correct behavior of this default
418 ;; is. It's not clear how to generalize the FBOUNDP expression to
419 ;; the cross-compiler. As far as I can tell, NIL is a safe default
420 ;; -- it might keep the compiler from making some valid
421 ;; optimization, but it shouldn't produce incorrect code. -- WHN
425 #-sb-xc-host
(lambda (name) (if (fboundp name
) :function nil
)))
427 ;;; The type specifier for this function.
428 (define-info-type (:function
:type
)
430 ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
431 ;; not clear how to generalize the FBOUNDP expression to the
432 ;; cross-compiler. -- WHN 19990330
434 ;; Delay evaluation of (SPECIFIER-TYPE) since it can't work yet
435 #+sb-xc-host
(lambda (x) (declare (ignore x
)) (specifier-type 'function
))
436 #-sb-xc-host
(lambda (name)
438 (handler-bind ((style-warning #'muffle-warning
))
439 (specifier-type (sb!impl
::%fun-type
(fdefinition name
))))
440 (specifier-type 'function
))))
442 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
443 ;;; due to not having a declaration or definition
444 (define-info-type (:function
:assumed-type
)
445 ;; FIXME: The type-spec really should be
446 ;; (or approximate-fun-type null)).
447 ;; It was changed to T as a hopefully-temporary hack while getting
448 ;; cold init problems untangled.
451 ;;; where this information came from:
452 ;;; :ASSUMED = from uses of the object
453 ;;; :DEFINED = from examination of the definition
454 ;;; :DEFINED-METHOD = implicit, incremental declaration by CLOS.
455 ;;; :DECLARED = from a declaration
456 ;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
457 ;;; and :DECLARED trumps :DEFINED-METHOD.
458 ;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
459 ;;; :DEFINED-METHOD and :DECLARED are useful for ANSIly specializing
460 ;;; code which implements the function, or which uses the function's
462 (define-info-type (:function
:where-from
)
463 :type-spec
(member :declared
:defined-method
:assumed
:defined
)
465 ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
466 ;; not clear how to generalize the FBOUNDP expression to the
467 ;; cross-compiler. -- WHN 19990606
468 #+sb-xc-host
:assumed
469 #-sb-xc-host
(lambda (name) (if (fboundp name
) :defined
:assumed
)))
471 ;;; something which can be decoded into the inline expansion of the
472 ;;; function, or NIL if there is none
474 ;;; To inline a function, we want a lambda expression, e.g.
475 ;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two
477 ;;; * The value in INFO can be the lambda expression itself, e.g.
478 ;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO)
479 ;;; '(LAMBDA (X) (+ X 1)))
480 ;;; This is the ordinary way, the natural way of representing e.g.
481 ;;; (DECLAIM (INLINE FOO))
482 ;;; (DEFUN FOO (X) (+ X 1))
483 ;;; * The value in INFO can be a closure which returns the lambda
485 ;;; (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD)
487 ;;; '(LAMBDA (BAR) (BAR-REF BAR 3))))
488 ;;; This twisty way of storing values is supported in order to
489 ;;; allow structure slot accessors, and perhaps later other
490 ;;; stereotyped functions, to be represented compactly.
491 (define-info-type (:function
:inline-expansion-designator
)
492 :type-spec
(or list function
))
494 ;;; This specifies whether this function may be expanded inline. If
495 ;;; null, we don't care.
496 (define-info-type (:function
:inlinep
) :type-spec inlinep
)
498 ;;; Track how many times IR2 converted a call to this function as a full call
499 ;;; that was not in the scope of a local or global notinline declaration.
500 ;;; Useful for finding functions that were supposed to have been converted
501 ;;; through some kind of transformation but were not.
502 (define-info-type (:function
:emitted-full-calls
) :type-spec list
)
504 ;;; a macro-like function which transforms a call to this function
505 ;;; into some other Lisp form. This expansion is inhibited if inline
506 ;;; expansion is inhibited.
507 ;;; As an exception, a cons of two atoms represents structure metadata
508 ;;; which is recognized and transformed in a stylized way.
509 (define-info-type (:function
:source-transform
)
510 :type-spec
(or function null
(cons atom atom
)))
512 ;;; the macroexpansion function for this macro
513 (define-info-type (:function
:macro-function
) :type-spec
(or function null
))
515 ;;; the compiler-macroexpansion function for this macro
516 (define-info-type (:function
:compiler-macro-function
)
517 :type-spec
(or function null
))
519 ;;; a function which converts this special form into IR1
520 (define-info-type (:function
:ir1-convert
) :type-spec
(or function null
))
522 ;;; If a function is "known" to the compiler, then this is a FUN-INFO
523 ;;; structure containing the info used to special-case compilation.
524 (define-info-type (:function
:info
) :type-spec
(or fun-info null
))
527 ;;;; ":VARIABLE" subsection - Data pertaining to globally known variables.
529 ;;; the kind of variable-like thing described
530 (define-info-type (:variable
:kind
)
531 :type-spec
(member :special
:constant
:macro
:global
:alien
:unknown
)
532 :default
(lambda (name)
533 (if (typep name
'(or boolean keyword
))
537 (define-info-type (:variable
:always-bound
)
538 :type-spec
(member nil
:eventually
:always-bound
))
540 (define-info-type (:variable
:deprecated
) :type-spec t
)
542 ;;; the declared type for this variable
543 (define-info-type (:variable
:type
)
545 ;; This gets set to *UNIVERSAL-TYPE* in 'late-type'
546 :default
(lambda (x) (declare (ignore x
)) (error "Too early for INFO")))
548 ;;; where this type and kind information came from
549 (define-info-type (:variable
:where-from
)
550 :type-spec
(member :declared
:assumed
:defined
) :default
:assumed
)
552 ;;; the macro-expansion for symbol-macros
553 (define-info-type (:variable
:macro-expansion
) :type-spec t
)
555 (define-info-type (:variable
:alien-info
)
556 :type-spec
(or heap-alien-info null
))
558 (define-info-type (:variable
:documentation
) :type-spec
(or string null
))
560 ;; :WIRED-TLS describes how SYMBOL-VALUE (implicit or not) should be compiled.
561 ;; - :ALWAYS-HAS-TLS means that calls to SYMBOL-VALUE should access the TLS
562 ;; with a fixed offset. The index is assigned no later than load-time of
563 ;; the file containing code thus compiled. Presence of an index in the
564 ;; image that performed compilation is irrelevant (for now).
565 ;; - :ALWAYS-THREAD-LOCAL implies a fixed offset, *and* that the check for
566 ;; no-tls-value may be elided. There is currently no way to set this.
567 ;; Note that this does not affect elision of the check for unbound-marker
568 ;; which is under control of the :ALWAYS-BOUND info.
569 ;; - an integer is a permanent index, and also implies :ALWAYS-THREAD-LOCAL.
570 ;; Specials in the CL package (notably reader/printer controls) use a wired-tls,
571 ;; whether or not we bind per-thread [if we don't, that's a bug!]
572 ;; We don't assume wired TLS more generally, because user code often defines
573 ;; thousands of DEFVARs, possibly due to poor style, or due to ANSI's stance
574 ;; that DEFCONSTANT is only for EQL-comparable objects. In such cases with
575 ;; more symbols than can be bound per-thread, the compiler won't exacerbate
576 ;; things by making the loader eagerly assign a TLS index to every symbol
577 ;; ever referenced by SYMBOL-VALUE or SET. Depletion should occur lazily.
579 (define-info-type (:variable
:wired-tls
)
580 :type-spec
(or (member nil
:always-has-tls
:always-thread-local
)
581 fixnum
) ; the actual index, for thread slots (to be done)
584 (declare (symbol symbol
))
585 (and (eq (info :variable
:kind symbol
) :special
)
587 (eq (symbol-package symbol
) *cl-package
*)
589 (flet ((external-in-package-p (pkg)
590 (and (string= (package-name (symbol-package symbol
)) pkg
)
591 (eq (nth-value 1 (find-symbol (string symbol
) pkg
))
593 ;; I'm not worried about random extra externals in some bizarro
594 ;; host lisp. TLS assignment has no bearing on semantics at all.
595 (or (external-in-package-p "COMMON-LISP")
596 (external-in-package-p "SB-XC")))
599 ;;;; ":TYPE" subsection - Data pertaining to globally known types.
601 ;;; the kind of type described. We return :INSTANCE for standard types
602 ;;; that are implemented as structures. For PCL classes, that have
603 ;;; only been compiled, but not loaded yet, we return
604 ;;; :FORTHCOMING-DEFCLASS-TYPE.
605 (define-info-type (:type
:kind
)
606 :type-spec
(member :primitive
:defined
:instance
607 :forthcoming-defclass-type nil
)
608 :validate-function
(lambda (name new-value
)
609 (declare (ignore new-value
))
610 (when (info :declaration
:recognized name
)
611 (error 'declaration-type-conflict-error
612 :format-arguments
(list name
)))))
614 ;;; the expander function for a defined type
615 (define-info-type (:type
:expander
) :type-spec
(or function null
))
617 (define-info-type (:type
:documentation
) :type-spec
(or string null
))
619 ;;; function that parses type specifiers into CTYPE structures
620 (define-info-type (:type
:translator
) :type-spec
(or function null
))
622 ;;; If true, then the type coresponding to this name. Note that if
623 ;;; this is a built-in class with a translation, then this is the
624 ;;; translation, not the class object. This info type keeps track of
625 ;;; various atomic types (NIL etc.) and also serves as a means to
626 ;;; ensure that common standard types are only consed once.
627 (define-info-type (:type
:builtin
) :type-spec
(or ctype null
))
629 ;;; The classoid-cell for this type
630 (define-info-type (:type
:classoid-cell
) :type-spec t
)
632 ;;; layout for this type being used by the compiler
633 (define-info-type (:type
:compiler-layout
)
634 :type-spec
(or layout null
)
635 :default
(lambda (name)
636 (let ((class (find-classoid name nil
)))
637 (when class
(classoid-layout class
)))))
639 ;;; DEFTYPE lambda-list
640 (define-info-type (:type
:lambda-list
) :type-spec list
)
642 (define-info-type (:type
:source-location
) :type-spec t
)
644 ;;;; ":TYPED-STRUCTURE" subsection.
645 ;;;; Data pertaining to structures that used DEFSTRUCT's :TYPE option.
646 (define-info-type (:typed-structure
:info
) :type-spec t
)
647 (define-info-type (:typed-structure
:documentation
) :type-spec
(or string null
))
649 ;;;; ":DECLARATION" subsection - Data pertaining to user-defined declarations.
650 ;; CLTL2 offers an API to provide a list of known declarations, but it is
651 ;; inefficient to iterate over all symbols to find ones which have the
652 ;; (:DECLARATION :RECOGNIZED) info.
653 ;; Therefore maintain a list of recognized declarations. This list makes the
654 ;; globaldb storage of same redundant, but oh well.
655 (defglobal *recognized-declarations
* nil
)
656 (define-info-type (:declaration
:recognized
)
658 ;; There's no portable way to unproclaim that a symbol is a declaration,
659 ;; but at the low-level permit new-value to be NIL.
660 :validate-function
(lambda (name new-value
)
661 (declare (symbol name
))
663 (when (info :type
:kind name
)
664 (error 'declaration-type-conflict-error
665 :format-arguments
(list name
)))
666 (pushnew name
*recognized-declarations
*))
668 (setq *recognized-declarations
*
669 (delete name
*recognized-declarations
*))))))
671 (define-info-type (:declaration
:handler
) :type-spec
(or function null
))
673 ;;;; ":ALIEN-TYPE" subsection - Data pertaining to globally known alien-types.
674 (define-info-type (:alien-type
:kind
)
675 :type-spec
(member :primitive
:defined
:unknown
)
677 (define-info-type (:alien-type
:translator
) :type-spec
(or function null
))
678 (define-info-type (:alien-type
:definition
) :type-spec
(or alien-type null
))
679 (define-info-type (:alien-type
:struct
) :type-spec
(or alien-type null
))
680 (define-info-type (:alien-type
:union
) :type-spec
(or alien-type null
))
681 (define-info-type (:alien-type
:enum
) :type-spec
(or alien-type null
))
683 ;;;; ":SETF" subsection - Data pertaining to expansion of the omnipotent macro.
684 (define-info-type (:setf
:inverse
) :type-spec
(or symbol null
))
685 (define-info-type (:setf
:documentation
) :type-spec
(or string null
))
686 (define-info-type (:setf
:expander
) :type-spec
(or function null
))
688 ;;;; ":CAS" subsection - Like SETF but there are no "inverses", just expanders
689 (define-info-type (:cas
:expander
) :type-spec
(or function null
))
691 ;;;; ":RANDOM-DOCUMENTATION" subsection.
692 ;;; This is used for storing miscellaneous documentation types. The
693 ;;; stuff is an alist translating documentation kinds to values.
694 (define-info-type (:random-documentation
:stuff
) :type-spec list
)
696 ;;;; ":SOURCE-LOCATION" subsection.
697 ;;; This is kind of the opposite of what I'd have thought more logical,
698 ;;; where each of the above subsections - also called "info classes" -
699 ;;; has one of its kinds of information being :SOURCE-LOCATION. And in fact
700 ;;; that *is* how :TYPE was handled. However, many global entities
701 ;;; store their source-location hanging off some other hook, avoiding the
702 ;;; globaldb entirely, such as functions using a #<code-component>.
703 ;;; So either way is basically a hodgepodge.
705 (define-info-type (:source-location
:variable
) :type-spec t
)
706 (define-info-type (:source-location
:constant
) :type-spec t
)
707 (define-info-type (:source-location
:typed-structure
) :type-spec t
)
708 (define-info-type (:source-location
:symbol-macro
) :type-spec t
)
710 ;; This is for the SB-INTROSPECT contrib module, and debugging.
711 (defun call-with-each-info (function symbol
)
712 (awhen (symbol-info-vector symbol
)
713 (%call-with-each-info function it symbol
)))
715 ;; This is for debugging at the REPL.
716 (defun show-info (sym)
719 (lambda (name type-num val
)
720 (unless (eq name prev
)
721 (format t
"~&~S" (setq prev name
)))
722 (let ((type (svref *info-types
* type-num
)))
723 (format t
"~& ~@[type ~D~]~@[~{~S ~S~}~] = "
724 (if (not type
) type-num
)
726 (list (type-info-class type
) (type-info-name type
))))
727 (write val
:level
1)))
730 ;;; Source transforms / compiler macros for INFO functions.
732 ;;; When building the XC, we give it a source transform, so that it can
733 ;;; compile INFO calls in the target efficiently; we also give it a compiler
734 ;;; macro, so that at least those INFO calls compiled after this file can be
735 ;;; efficient. (Host compiler-macros do not fire when compiling the target,
736 ;;; and source transforms don't fire when building the XC, so we need both.)
738 ;;; Target needs just one, since there compiler macros and source-transforms
740 (macrolet ((def (name lambda-list form
)
741 (aver (member 'class lambda-list
))
742 (aver (member 'type lambda-list
))
744 ;; FIXME: instead of a macro and a transform, just define the macro
745 ;; early enough for both host and target compilation to see.
747 (define-source-transform ,name
,lambda-list
748 (if (and (keywordp class
) (keywordp type
))
751 (define-compiler-macro ,name
,(append '(&whole .whole.
) lambda-list
)
752 (if (and (keywordp class
) (keywordp type
))
756 (def info
(class type name
)
757 (let ((info (type-info-or-lose class type
)))
758 `(truly-the (values ,(type-info-type-spec info
) boolean
)
759 (get-info-value ,name
,(type-info-number info
)))))
761 (def (setf info
) (new-value class type name
)
762 (let* (#+sb-xc-host
(sb!xc
:*gensym-counter
* sb
!xc
:*gensym-counter
*)
763 (info (type-info-or-lose class type
))
764 (tin (type-info-number info
))
765 (type-spec (type-info-type-spec info
))
767 (when (type-info-validate-function info
)
768 ;; is (or ... null), but non-null in host implies non-null
770 (type-info-validate-function
771 (truly-the type-info
(svref *info-types
* ,tin
)))))))
772 (with-unique-names (new)
773 `(let ((,new
,new-value
))
774 ;; enforce type-correctness regardless of enclosing policy
775 (let ((,new
(locally (declare (optimize (safety 3)))
776 (the ,type-spec
,new
))))
778 `((funcall ,check
,name
,new
)))
779 (set-info-value ,name
,tin
,new
))))))
781 (def clear-info
(class type name
)
782 (let ((info (type-info-or-lose class type
)))
783 `(clear-info-values ,name
'(,(type-info-number info
))))))
785 (!defun-from-collected-cold-init-forms
!globaldb-cold-init
)