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 a 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 ;;;; This software is part of the SBCL system. See the README file for
17 ;;;; more information.
19 ;;;; This software is derived from the CMU CL system, which was
20 ;;;; written at Carnegie Mellon University and released into the
21 ;;;; public domain. The software is in the public domain and is
22 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
23 ;;;; files for more information.
27 (!begin-collecting-cold-init-forms)
28 #!+sb-show (!cold-init-forms (/show0 "early in globaldb.lisp cold init"))
30 ;;; The DEFVAR for this appears later.
32 (declaim (special *universal-type*))
34 ;;; This is sorta semantically equivalent to SXHASH, but optimized for
35 ;;; legal function names. Note: semantically equivalent does *not*
36 ;;; mean that it always returns the same value as SXHASH, just that it
37 ;;; satisfies the formal definition of SXHASH. The ``sorta'' is
38 ;;; because SYMBOL-HASH will not necessarily return the same value in
39 ;;; different lisp images.
41 ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
43 ;;; 1. This hash function has to run when we're initializing the globaldb,
44 ;;; so it has to run before the type system is initialized, and it's
45 ;;; easier to make it do this if we don't try to do a general TYPECASE.
46 ;;; 2. This function is in a potential bottleneck for the compiler,
47 ;;; and avoiding the general TYPECASE lets us improve performance
49 ;;; 2a. the general TYPECASE is intrinsically slow, and
50 ;;; 2b. the general TYPECASE is too big for us to easily afford
51 ;;; to inline it, so it brings with it a full function call.
53 ;;; Why not specialize instead of optimize? (I.e. why fall through to
54 ;;; general SXHASH as a last resort?) Because the INFO database is used
55 ;;; to hold all manner of things, e.g. (INFO :TYPE :BUILTIN ..)
56 ;;; which is called on values like (UNSIGNED-BYTE 29). Falling through
57 ;;; to SXHASH lets us support all manner of things (as long as they
58 ;;; aren't used too early in cold boot for SXHASH to run).
59 #!-sb-fluid (declaim (inline globaldb-sxhashoid))
60 (defun globaldb-sxhashoid (x)
61 (cond #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
64 #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
67 (let ((rest (rest x)))
68 (and (symbolp (car rest))
70 (logxor (symbol-hash (second x))
74 ;;; Given any non-negative integer, return a prime number >= to it.
76 ;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
77 ;;; hash-table.lisp. Perhaps the merged logic should be
78 ;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
79 ;;; after integral powers of two:
80 ;;; #(17 37 67 131 ..)
81 ;;; (Or, if that's too coarse, after half-integral powers of two.) By
82 ;;; thus getting rid of any need for primality testing at runtime, we
83 ;;; could punt POSITIVE-PRIMEP, too.
85 (declare (type unsigned-byte x))
86 (do ((n (logior x 1) (+ n 2)))
87 ((sb!sys:positive-primep n)
90 ;;;; info classes, info types, and type numbers, part I: what's needed
91 ;;;; not only at compile time but also at run time
93 ;;;; Note: This section is a blast from the past, a little trip down
94 ;;;; memory lane to revisit the weird host/target interactions of the
95 ;;;; CMU CL build process. Because of the way that the cross-compiler
96 ;;;; and target compiler share stuff here, if you change anything in
97 ;;;; here, you'd be well-advised to nuke all your fasl files and
98 ;;;; restart compilation from the very beginning of the bootstrap
101 ;;; At run time, we represent the type of info that we want by a small
102 ;;; non-negative integer.
103 (defconstant type-number-bits 6)
104 (deftype type-number () `(unsigned-byte ,type-number-bits))
106 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
107 ;;; running the cross-compiler? The cross-compiler (which was built
108 ;;; from these sources) has its version of these data and functions
109 ;;; defined in the same places we'd be defining into. We're happy with
110 ;;; its version, since it was compiled from the same sources, so
111 ;;; there's no point in overwriting its nice compiled version of this
112 ;;; stuff with our interpreted version. (And any time we're *not*
113 ;;; happy with its version, perhaps because we've been editing the
114 ;;; sources partway through bootstrapping, tch tch, overwriting its
115 ;;; version with our version would be unlikely to help, because that
116 ;;; would make the cross-compiler very confused.)
117 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
119 (defstruct (class-info
120 (:constructor make-class-info (name))
121 #-no-ansi-print-object
122 (:print-object (lambda (x s)
123 (print-unreadable-object (x s :type t)
124 (prin1 (class-info-name x))))))
125 ;; name of this class
126 (name nil :type keyword :read-only t)
127 ;; List of Type-Info structures for each type in this class.
128 (types () :type list))
130 ;;; a map from type numbers to TYPE-INFO objects. There is one type
131 ;;; number for each defined CLASS/TYPE pair.
133 ;;; We build its value at compile time (with calls to
134 ;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
135 ;;; value, and arrange for that code to be called in cold load.
136 (defvar *info-types*)
137 (declaim (type simple-vector *info-types*))
138 (eval-when (:compile-toplevel :execute)
140 (make-array (ash 1 type-number-bits) :initial-element nil)))
142 (defstruct (type-info
143 #-no-ansi-print-object
144 (:print-object (lambda (x s)
145 (print-unreadable-object (x s)
148 (class-info-name (type-info-class x))
150 (type-info-number x))))))
151 ;; the name of this type
152 (name (required-argument) :type keyword)
154 (class (required-argument) :type class-info)
155 ;; a number that uniquely identifies this type (and implicitly its class)
156 (number (required-argument) :type type-number)
157 ;; a type specifier which info of this type must satisfy
159 ;; a function called when there is no information of this type
160 (default (lambda () (error "type not defined yet")) :type function))
162 ;;; a map from class names to CLASS-INFO structures
164 ;;; We build the value for this at compile time (with calls to
165 ;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
166 ;;; value, and arrange for that code to be called in cold load.
167 (defvar *info-classes*)
168 (declaim (hash-table *info-classes*))
169 (eval-when (:compile-toplevel :execute)
170 (setf *info-classes* (make-hash-table)))
172 ;;; If Name is the name of a type in Class, then return the TYPE-INFO,
174 (defun find-type-info (name class)
175 (declare (type keyword name) (type class-info class))
176 (dolist (type (class-info-types class) nil)
177 (when (eq (type-info-name type) name)
180 ;;; Return the info structure for an info class or type, or die trying.
181 (declaim (ftype (function (keyword) class-info) class-info-or-lose))
182 (defun class-info-or-lose (class)
183 (declare (type keyword class))
184 (or (gethash class *info-classes*)
185 (error "~S is not a defined info class." class)))
186 (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
187 (defun type-info-or-lose (class type)
188 (or (find-type-info type (class-info-or-lose class))
189 (error "~S is not a defined info type." type)))
193 ;;;; info classes, info types, and type numbers, part II: what's
194 ;;;; needed only at compile time, not at run time
196 ;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS
197 ;;; and the calls to it) could/should go in a separate file,
198 ;;; perhaps info-classes.lisp?
200 (eval-when (:compile-toplevel :execute)
202 ;;; Set up the data structures to support an info class. We make sure
203 ;;; that the class exists at compile time so that macros can use it,
204 ;;; but don't actually store the init function until load time so that
205 ;;; we don't break the running compiler.
206 (#+sb-xc-host defmacro
207 #-sb-xc-host sb!xc:defmacro
208 define-info-class (class)
210 "Define-Info-Class Class
211 Define a new class of global information."
212 (declare (type keyword class))
214 ;; (We don't need to evaluate this at load time, compile time is
215 ;; enough. There's special logic elsewhere which deals with cold
216 ;; load initialization by inspecting the info class data
217 ;; structures at compile time and generating code to recreate
218 ;; those data structures.)
219 (eval-when (:compile-toplevel :execute)
220 (unless (gethash ,class *info-classes*)
221 (setf (gethash ,class *info-classes*) (make-class-info ,class))))
224 ;;; Find a type number not already in use by looking for a null entry
226 (defun find-unused-type-number ()
227 (or (position nil *info-types*)
228 (error "no more INFO type numbers available")))
230 ;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO
231 ;;; objects, accumulated during compilation and eventually converted
232 ;;; into a function to be called at cold load time after the
233 ;;; appropriate TYPE-INFO objects have been created
235 ;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
236 ;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery
237 ;;; here. The problem is that the natural order in which the
238 ;;; default-slot-initialization forms are generated relative to the
239 ;;; order in which the TYPE-INFO-creation forms are generated doesn't
240 ;;; match the relative order in which the forms need to be executed at
242 (defparameter *reversed-type-info-init-forms* nil)
244 ;;; The main thing we do is determine the type's number. We need to do
245 ;;; this at macroexpansion time, since both the COMPILE and LOAD time
246 ;;; calls to %DEFINE-INFO-TYPE must use the same type number.
247 (#+sb-xc-host defmacro
248 #-sb-xc-host sb!xc:defmacro
249 define-info-type (&key (class (required-argument))
250 (type (required-argument))
251 (type-spec (required-argument))
254 "Define-Info-Type Class Type default Type-Spec
255 Define a new type of global information for Class. Type is the name
256 of the type, Default is the value for that type when it hasn't been set, and
257 Type-Spec is a type-specifier which values of the type must satisfy. The
258 default expression is evaluated each time the information is needed, with
259 Name bound to the name for which the information is being looked up. If the
260 default evaluates to something with the second value true, then the second
261 value of Info will also be true."
262 (declare (type keyword class type))
264 (eval-when (:compile-toplevel :execute)
265 ;; At compile time, ensure that the type number exists. It will
266 ;; need to be forced to exist at cold load time, too, but
267 ;; that's not handled here; it's handled by later code which
268 ;; looks at the compile time state and generates code to
269 ;; replicate it at cold load time.
270 (let* ((class-info (class-info-or-lose ',class))
271 (old-type-info (find-type-info ',type class-info)))
272 (unless old-type-info
273 (let* ((new-type-number (find-unused-type-number))
275 (make-type-info :name ',type
277 :number new-type-number)))
278 (setf (aref *info-types* new-type-number) new-type-info)
279 (push new-type-info (class-info-types class-info)))))
280 ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
281 ;; at cold load time. (They can't very well be set at
282 ;; cross-compile time, since they differ between the
283 ;; cross-compiler and the target. The DEFAULT slot values
284 ;; differ because they're compiled closures, and the TYPE slot
285 ;; values differ in the use of SB!XC symbols instead of CL
287 (push `(let ((type-info (type-info-or-lose ,',class ,',type)))
288 (setf (type-info-default type-info)
289 ;; FIXME: This code is sort of nasty. It would
290 ;; be cleaner if DEFAULT accepted a real
291 ;; function, instead of accepting a statement
292 ;; which will be turned into a lambda assuming
293 ;; that the argument name is NAME. It might
294 ;; even be more microefficient, too, since many
295 ;; DEFAULTs could be implemented as (CONSTANTLY
296 ;; NIL) instead of full-blown (LAMBDA (X) NIL).
298 (declare (ignorable name))
300 (setf (type-info-type type-info) ',',type-spec))
301 *reversed-type-info-init-forms*))
306 ;;;; generic info environments
308 ;;; Note: the CACHE-NAME slot is deliberately not shared for
309 ;;; bootstrapping reasons. If we access with accessors for the exact
310 ;;; type, then the inline type check will win. If the inline check
311 ;;; didn't win, we would try to use the type system before it was
312 ;;; properly initialized.
313 (defstruct (info-env (:constructor nil))
314 ;; some string describing what is in this environment, for
315 ;; printing/debugging purposes only
316 (name (required-argument) :type string))
317 (def!method print-object ((x info-env) stream)
318 (print-unreadable-object (x stream :type t)
319 (prin1 (info-env-name x) stream)))
321 ;;;; generic interfaces
323 ;;; FIXME: used only in this file, needn't be in runtime
324 (defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
325 (type-number (gensym)) (value (gensym)) known-volatile)
328 "DO-INFO (Env &Key Name Class Type Value) Form*
329 Iterate over all the values stored in the Info-Env Env. Name is bound to
330 the entry's name, Class and Type are bound to the class and type
331 (represented as keywords), and Value is bound to the entry's value."
332 (once-only ((n-env env))
334 (do-volatile-info name class type type-number value n-env body)
335 `(if (typep ,n-env 'volatile-info-env)
336 ,(do-volatile-info name class type type-number value n-env body)
337 ,(do-compact-info name class type type-number value
340 (eval-when (:compile-toplevel :load-toplevel :execute)
342 ;;; Return code to iterate over a compact info environment.
343 (defun do-compact-info (name-var class-var type-var type-number-var value-var
345 (let ((n-index (gensym))
348 (once-only ((n-table `(compact-info-env-table ,n-env))
349 (n-entries-index `(compact-info-env-index ,n-env))
350 (n-entries `(compact-info-env-entries ,n-env))
351 (n-entries-info `(compact-info-env-entries-info ,n-env))
352 (n-info-types '*info-types*))
353 `(dotimes (,n-index (length ,n-table))
354 (declare (type index ,n-index))
356 (let ((,name-var (svref ,n-table ,n-index)))
357 (unless (eql ,name-var 0)
358 (do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
361 (declare (type index ,n-type))
362 ,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
363 `(let ((,type-number-var
364 (logand ,n-info compact-info-entry-type-mask)))
365 ,(once-only ((n-type-info
366 `(svref ,n-info-types
368 `(let ((,type-var (type-info-name ,n-type-info))
369 (,class-var (class-info-name
370 (type-info-class ,n-type-info)))
371 (,value-var (svref ,n-entries ,n-type)))
372 (declare (ignorable ,type-var ,class-var
375 (unless (zerop (logand ,n-info compact-info-entry-last))
376 (return-from ,PUNT))))))))))))))
378 ;;; Return code to iterate over a volatile info environment.
379 (defun do-volatile-info (name-var class-var type-var type-number-var value-var
381 (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
382 (once-only ((n-table `(volatile-info-env-table ,n-env))
383 (n-info-types '*info-types*))
384 `(dotimes (,n-index (length ,n-table))
385 (declare (type index ,n-index))
386 (do-anonymous ((,n-names (svref ,n-table ,n-index)
389 (let ((,name-var (caar ,n-names)))
390 (declare (ignorable ,name-var))
391 (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
393 (let ((,type-number-var (caar ,n-types)))
394 ,(once-only ((n-type `(svref ,n-info-types
396 `(let ((,type-var (type-info-name ,n-type))
397 (,class-var (class-info-name
398 (type-info-class ,n-type)))
399 (,value-var (cdar ,n-types)))
400 (declare (ignorable ,type-var ,class-var ,value-var))
407 ;;;; We use a hash cache to cache name X type => value for the current
408 ;;;; value of *INFO-ENVIRONMENT*. This is in addition to the
409 ;;;; per-environment caching of name => types.
411 ;;; The value of *INFO-ENVIRONMENT* that has cached values.
412 ;;; *INFO-ENVIRONMENT* should never be destructively modified, so if
413 ;;; it is EQ to this, then the cache is valid.
414 (defvar *cached-info-environment*)
416 (setf *cached-info-environment* nil))
418 ;;; the hash function used for the INFO cache
419 #!-sb-fluid (declaim (inline info-cache-hash))
420 (defun info-cache-hash (name type)
423 (logxor (globaldb-sxhashoid name)
424 (ash (the fixnum type) 7)))
428 (/show0 "before initialization of INFO hash cache"))
429 (define-hash-cache info ((name eq) (type eq))
431 :hash-function info-cache-hash
433 :default (values nil :empty)
434 :init-wrapper !cold-init-forms)
436 (/show0 "clearing INFO hash cache")
438 (/show0 "done clearing INFO hash cache"))
440 ;;; If the info cache is invalid, then clear it.
441 #!-sb-fluid (declaim (inline clear-invalid-info-cache))
442 (defun clear-invalid-info-cache ()
443 ;; Unless the cache is valid..
444 (unless (eq *info-environment* *cached-info-environment*)
445 (;; In the target Lisp, this should be done without interrupts,
446 ;; but in the host Lisp when cross-compiling, we don't need to
447 ;; sweat it, since no affected-by-GC hashes should be used when
448 ;; running under the host Lisp (since that's non-portable) and
449 ;; since only one thread should be used when running under the
450 ;; host Lisp (because multiple threads are non-portable too).
451 #-sb-xc-host without-interrupts
454 (setq *cached-info-environment* *info-environment*))))
456 ;;;; compact info environments
458 ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
459 (defconstant compact-info-env-entries-bits 16)
460 (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
462 ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO
463 (deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))
465 ;;; This is an open hashtable with rehashing. Since modification is
466 ;;; not allowed, we don't have to worry about deleted entries. We
467 ;;; indirect through a parallel vector to find the index in the
468 ;;; ENTRIES at which the entries for a given name starts.
469 (defstruct (compact-info-env (:include info-env)
470 #-sb-xc-host (:pure :substructure))
471 ;; If this value is EQ to the name we want to look up, then the
472 ;; cache hit function can be called instead of the lookup function.
474 ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has
476 (cache-index nil :type (or compact-info-entries-index null))
477 ;; hashtable of the names in this environment. If a bucket is
479 (table (required-argument) :type simple-vector)
480 ;; an indirection vector parallel to TABLE, translating indices in
481 ;; TABLE to the start of the ENTRIES for that name. Unused entries
483 (index (required-argument)
484 :type (simple-array compact-info-entries-index (*)))
485 ;; a vector contining in contiguous ranges the values of for all the
486 ;; types of info for each name.
487 (entries (required-argument) :type simple-vector)
488 ;; Vector parallel to ENTRIES, indicating the type number for the value
489 ;; stored in that location and whether this location is the last type of info
490 ;; stored for this name. The type number is in the low TYPE-NUMBER-BITS
491 ;; bits, and the next bit is set if this is the last entry.
492 (entries-info (required-argument)
493 :type (simple-array compact-info-entry (*))))
495 (defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
496 (defconstant compact-info-entry-last (ash 1 type-number-bits))
498 ;;; Return the value of the type corresponding to Number for the currently
499 ;;; cached name in Env.
500 #!-sb-fluid (declaim (inline compact-info-cache-hit))
501 (defun compact-info-cache-hit (env number)
502 (declare (type compact-info-env env) (type type-number number))
503 (let ((entries-info (compact-info-env-entries-info env))
504 (index (compact-info-env-cache-index env)))
506 (do ((index index (1+ index)))
508 (declare (type index index))
509 (let ((info (aref entries-info index)))
510 (when (= (logand info compact-info-entry-type-mask) number)
511 (return (values (svref (compact-info-env-entries env) index)
513 (unless (zerop (logand compact-info-entry-last info))
514 (return (values nil nil)))))
517 ;;; Encache Name in the compact environment Env. Hash is the
518 ;;; GLOBALDB-SXHASHOID of Name.
519 (defun compact-info-lookup (env name hash)
520 (declare (type compact-info-env env) (type index hash))
521 (let* ((table (compact-info-env-table env))
524 (hash2 (- len-2 (rem hash len-2))))
525 (declare (type index len-2 hash2))
526 (macrolet ((lookup (test)
527 `(do ((probe (rem hash len)
528 (let ((new (+ probe hash2)))
529 (declare (type index new))
530 ;; same as (mod new len), but faster.
532 (the index (- new len))
535 (let ((entry (svref table probe)))
538 (when (,test entry name)
539 (return (aref (compact-info-env-index env)
541 (setf (compact-info-env-cache-index env)
545 (setf (compact-info-env-cache-name env) name)))
549 ;;; the exact density (modulo rounding) of the hashtable in a compact
550 ;;; info environment in names/bucket
551 (defconstant compact-info-environment-density 65)
553 ;;; Iterate over the environment once to find out how many names and entries
554 ;;; it has, then build the result. This code assumes that all the entries for
555 ;;; a name well be iterated over contiguously, which holds true for the
556 ;;; implementation of iteration over both kinds of environments.
558 ;;; When building the table, we sort the entries by POINTER< in an attempt
559 ;;; to preserve any VM locality present in the original load order, rather than
560 ;;; randomizing with the original hash function.
561 (defun compact-info-environment (env &key (name (info-env-name env)))
563 "Return a new compact info environment that holds the same information as
570 (do-info (env :name name :type-number num :value value)
571 (unless (eq name prev-name)
573 (unless (eql prev-name 0)
574 (names (cons prev-name types)))
575 (setq prev-name name)
578 (push (cons num value) types))
579 (unless (eql prev-name 0)
580 (names (cons prev-name types))))
582 (let* ((table-size (primify
583 (+ (truncate (* name-count 100)
584 compact-info-environment-density)
586 (table (make-array table-size :initial-element 0))
587 (index (make-array table-size
588 :element-type 'compact-info-entries-index))
589 (entries (make-array entry-count))
590 (entries-info (make-array entry-count
591 :element-type 'compact-info-entry))
592 (sorted (sort (names)
594 #-sb-xc-host (lambda (x y)
595 ;; FIXME: What's going on here?
596 (< (%primitive make-fixnum x)
597 (%primitive make-fixnum y))))))
598 (let ((entries-idx 0))
599 (dolist (types sorted)
600 (let* ((name (first types))
601 (hash (globaldb-sxhashoid name))
602 (len-2 (- table-size 2))
603 (hash2 (- len-2 (rem hash len-2))))
604 (do ((probe (rem hash table-size)
605 (rem (+ probe hash2) table-size)))
607 (let ((entry (svref table probe)))
609 (setf (svref table probe) name)
610 (setf (aref index probe) entries-idx)
612 (assert (not (equal entry name))))))
614 (unless (zerop entries-idx)
615 (setf (aref entries-info (1- entries-idx))
616 (logior (aref entries-info (1- entries-idx))
617 compact-info-entry-last)))
619 (loop for (num . value) in (rest types) do
620 (setf (aref entries-info entries-idx) num)
621 (setf (aref entries entries-idx) value)
624 (unless (zerop entry-count)
625 (setf (aref entries-info (1- entry-count))
626 (logior (aref entries-info (1- entry-count))
627 compact-info-entry-last)))
629 (make-compact-info-env :name name
633 :entries-info entries-info))))))
635 ;;;; volatile environments
637 ;;; This is a closed hashtable, with the bucket being computed by taking the
638 ;;; GLOBALDB-SXHASHOID of the Name mod the table size.
639 (defstruct (volatile-info-env (:include info-env))
640 ;; If this value is EQ to the name we want to look up, then the cache hit
641 ;; function can be called instead of the lookup function.
643 ;; The alist translating type numbers to values for the currently cached
645 (cache-types nil :type list)
646 ;; Vector of alists of alists of the form:
647 ;; ((Name . ((Type-Number . Value) ...) ...)
648 (table (required-argument) :type simple-vector)
649 ;; The number of distinct names currently in this table (each name may have
650 ;; multiple entries, since there can be many types of info.
651 (count 0 :type index)
652 ;; The number of names at which we should grow the table and rehash.
653 (threshold 0 :type index))
655 ;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
656 #!-sb-fluid (declaim (inline volatile-info-cache-hit))
657 (defun volatile-info-cache-hit (env number)
658 (declare (type volatile-info-env env) (type type-number number))
659 (dolist (type (volatile-info-env-cache-types env) (values nil nil))
660 (when (eql (car type) number)
661 (return (values (cdr type) t)))))
663 ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
664 (defun volatile-info-lookup (env name hash)
665 (declare (type volatile-info-env env) (type index hash))
666 (let ((table (volatile-info-env-table env)))
667 (macrolet ((lookup (test)
668 `(dolist (entry (svref table (mod hash (length table))) ())
669 (when (,test (car entry) name)
670 (return (cdr entry))))))
671 (setf (volatile-info-env-cache-types env)
675 (setf (volatile-info-env-cache-name env) name)))
679 ;;; Given a volatile environment Env, bind Table-Var the environment's table
680 ;;; and Index-Var to the index of Name's bucket in the table. We also flush
681 ;;; the cache so that things will be consistent if body modifies something.
682 (eval-when (:compile-toplevel :execute)
683 (#+sb-xc-host cl:defmacro
684 #-sb-xc-host sb!xc:defmacro
685 with-info-bucket ((table-var index-var name env) &body body)
686 (once-only ((n-name name)
689 (setf (volatile-info-env-cache-name ,n-env) 0)
690 (let* ((,table-var (volatile-info-env-table ,n-env))
691 (,index-var (mod (globaldb-sxhashoid ,n-name)
692 (length ,table-var))))
695 ;;; Get the info environment that we use for write/modification operations.
696 ;;; This is always the first environment in the list, and must be a
697 ;;; VOLATILE-INFO-ENV.
698 #!-sb-fluid (declaim (inline get-write-info-env))
699 (defun get-write-info-env (&optional (env-list *info-environment*))
700 (let ((env (car env-list)))
702 (error "no info environment?"))
703 (unless (typep env 'volatile-info-env)
704 (error "cannot modify this environment: ~S" env))
705 (the volatile-info-env env)))
707 ;;; If Name is already present in the table, then just create or
708 ;;; modify the specified type. Otherwise, add the new name and type,
709 ;;; checking for rehashing.
711 ;;; We rehash by making a new larger environment, copying all of the
712 ;;; entries into it, then clobbering the old environment with the new
713 ;;; environment's table. We clear the old table to prevent it from
714 ;;; holding onto garbage if it is statically allocated.
716 ;;; We return the new value so that this can be conveniently used in a
718 (defun set-info-value (name0 type new-value
719 &optional (env (get-write-info-env)))
720 (declare (type type-number type) (type volatile-info-env env)
722 (let ((name (uncross name0)))
724 (error "0 is not a legal INFO name."))
725 ;; We don't enter the value in the cache because we don't know that this
726 ;; info-environment is part of *cached-info-environment*.
727 (info-cache-enter name type nil :empty)
728 (with-info-bucket (table index name env)
729 (let ((types (if (symbolp name)
730 (assoc name (svref table index) :test #'eq)
731 (assoc name (svref table index) :test #'equal))))
734 (let ((value (assoc type (cdr types))))
736 (setf (cdr value) new-value)
737 (push (cons type new-value) (cdr types)))))
739 (push (cons name (list (cons type new-value)))
742 (let ((count (incf (volatile-info-env-count env))))
743 (when (>= count (volatile-info-env-threshold env))
744 (let ((new (make-info-environment :size (* count 2))))
745 (do-info (env :name entry-name :type-number entry-num
746 :value entry-val :known-volatile t)
747 (set-info-value entry-name entry-num entry-val new))
748 (fill (volatile-info-env-table env) nil)
749 (setf (volatile-info-env-table env)
750 (volatile-info-env-table new))
751 (setf (volatile-info-env-threshold env)
752 (volatile-info-env-threshold new)))))))))
755 ;;; FIXME: It should be possible to eliminate the hairy compiler macros below
756 ;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro
757 ;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the
758 ;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE
761 ;;; INFO is the standard way to access the database. It's settable.
762 (defun info (class type name &optional (env-list nil env-list-p))
764 "Return the information of the specified TYPE and CLASS for NAME.
765 The second value returned is true if there is any such information
766 recorded. If there is no information, the first value returned is
767 the default and the second value returned is NIL."
768 ;; FIXME: At some point check systematically to make sure that the system
769 ;; doesn't do any full calls to INFO or (SETF INFO), or at least none in any
771 (let ((info (type-info-or-lose class type)))
773 (get-info-value name (type-info-number info) env-list)
774 (get-info-value name (type-info-number info)))))
776 (define-compiler-macro info
777 (&whole whole class type name &optional (env-list nil env-list-p))
778 ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
779 ;; can resolve it much more efficiently than the general case.
780 (if (and (constantp class) (constantp type))
781 (let ((info (type-info-or-lose class type)))
782 `(the ,(type-info-type info)
783 (get-info-value ,name
784 ,(type-info-number info)
785 ,@(when env-list-p `(,env-list)))))
787 (defun (setf info) (new-value
791 &optional (env-list nil env-list-p))
792 (let* ((info (type-info-or-lose class type))
793 (tin (type-info-number info)))
798 (get-write-info-env env-list))
803 ;;; FIXME: We'd like to do this, but Python doesn't support
804 ;;; compiler macros and it's hard to change it so that it does.
805 ;;; It might make more sense to just convert INFO :FOO :BAR into
806 ;;; an ordinary function, so that instead of calling INFO :FOO :BAR
807 ;;; you call e.g. INFO%FOO%BAR. Then dynamic linking could be handled
808 ;;; by the ordinary Lisp mechanisms and we wouldn't have to maintain
813 (define-compiler-macro (setf info) (&whole whole
818 &optional (env-list nil env-list-p))
819 ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
820 ;; can resolve it much more efficiently than the general case.
821 (if (and (constantp class) (constantp type))
822 (let* ((info (type-info-or-lose class type))
823 (tin (type-info-number info)))
825 `(set-info-value ,name
828 (get-write-info-env ,env-list))
829 `(set-info-value ,name
835 ;;; the maximum density of the hashtable in a volatile env (in
838 ;;; FIXME: actually seems to be measured in percent, should be
839 ;;; converted to be measured in names/bucket
840 (defconstant volatile-info-environment-density 50)
842 ;;; Make a new volatile environment of the specified size.
843 (defun make-info-environment (&key (size 42) (name "Unknown"))
844 (declare (type (integer 1) size))
845 (let ((table-size (primify (truncate (* size 100)
846 volatile-info-environment-density))))
847 (make-volatile-info-env :name name
848 :table (make-array table-size :initial-element nil)
851 (defun clear-info (class type name)
853 "Clear the information of the specified Type and Class for Name in the
854 current environment, allowing any inherited info to become visible. We
855 return true if there was any info."
856 (let ((info (type-info-or-lose class type)))
857 (clear-info-value name (type-info-number info))))
859 (define-compiler-macro clear-info (&whole whole class type name)
860 ;; Constant CLASS and TYPE is an overwhelmingly common special case, and
861 ;; we can resolve it much more efficiently than the general case.
862 (if (and (keywordp class) (keywordp type))
863 (let ((info (type-info-or-lose class type)))
864 `(clear-info-value ,name ,(type-info-number info)))
866 (defun clear-info-value (name type)
867 (declare (type type-number type) (inline assoc))
868 (clear-invalid-info-cache)
869 (info-cache-enter name type nil :empty)
870 (with-info-bucket (table index name (get-write-info-env))
871 (let ((types (assoc name (svref table index) :test #'equal)))
873 (assoc type (cdr types)))
875 (delete type (cdr types) :key #'car))
878 ;;;; *INFO-ENVIRONMENT*
880 ;;; We do info access relative to the current *INFO-ENVIRONMENT*, a
881 ;;; list of INFO-ENVIRONMENT structures.
882 (defvar *info-environment*)
883 (declaim (type list *info-environment*))
885 (setq *info-environment*
886 (list (make-info-environment :name "initial global")))
887 (/show0 "done setting *INFO-ENVIRONMENT*"))
888 ;;; FIXME: should perhaps be *INFO-ENV-LIST*. And rename
889 ;;; all FOO-INFO-ENVIRONMENT-BAR stuff to FOO-INFO-ENV-BAR.
893 ;;; Check whether the name and type is in our cache, if so return it.
894 ;;; Otherwise, search for the value and encache it.
896 ;;; Return the value from the first environment which has it defined, or
897 ;;; return the default if none does. We have a cache for the last name looked
898 ;;; up in each environment. We don't compute the hash until the first time the
899 ;;; cache misses. When the cache does miss, we invalidate it before calling the
900 ;;; lookup routine to eliminate the possiblity of the cache being partially
901 ;;; updated if the lookup is interrupted.
902 (defun get-info-value (name0 type &optional (env-list nil env-list-p))
903 (declare (type type-number type))
904 (let ((name (uncross name0)))
905 (flet ((lookup-ignoring-global-cache (env-list)
907 (dolist (env env-list
908 (multiple-value-bind (val winp)
909 (funcall (type-info-default
910 (svref *info-types* type))
913 (macrolet ((frob (lookup cache slot)
915 (unless (eq name (,slot env))
917 (setq hash (globaldb-sxhashoid name)))
919 (,lookup env name hash))
920 (multiple-value-bind (value winp)
922 (when winp (return (values value t)))))))
923 (if (typep env 'volatile-info-env)
924 (frob volatile-info-lookup volatile-info-cache-hit
925 volatile-info-env-cache-name)
926 (frob compact-info-lookup compact-info-cache-hit
927 compact-info-env-cache-name)))))))
929 (lookup-ignoring-global-cache env-list))
931 (clear-invalid-info-cache)
932 (multiple-value-bind (val winp) (info-cache-lookup name type)
934 (multiple-value-bind (val winp)
935 (lookup-ignoring-global-cache *info-environment*)
936 (info-cache-enter name type val winp)
938 (values val winp))))))))
940 ;;;; definitions for function information
942 (define-info-class :function)
944 ;;; the kind of functional object being described. If null, NAME isn't
945 ;;; a known functional object.
949 :type-spec (member nil :function :macro :special-form)
950 ;; I'm a little confused what the correct behavior of this default
951 ;; is. It's not clear how to generalize the FBOUNDP expression to
952 ;; the cross-compiler. As far as I can tell, NIL is a safe default
953 ;; -- it might keep the compiler from making some valid
954 ;; optimization, but it shouldn't produce incorrect code. -- WHN
958 #-sb-xc-host (if (fboundp name) :function nil))
960 ;;; The type specifier for this function.
965 ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
966 ;; not clear how to generalize the FBOUNDP expression to the
967 ;; cross-compiler. -- WHN 19990330
969 #+sb-xc-host (specifier-type 'function)
970 #-sb-xc-host (if (fboundp name)
971 (extract-function-type (fdefinition name))
972 (specifier-type 'function)))
974 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
975 ;;; due to not having a declaration or definition
979 :type-spec (or approximate-function-type null))
981 ;;; where this information came from:
982 ;;; :DECLARED = from a declaration.
983 ;;; :ASSUMED = from uses of the object.
984 ;;; :DEFINED = from examination of the definition.
985 ;;; FIXME: The :DEFINED assumption that the definition won't change
986 ;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way
987 ;;; which violates its "type declarations are assertions" principle,
988 ;;; and SBCL has inherited that behavior. It would be really good to
989 ;;; fix the compiler so that it tests the return types of functions..
990 ;;; -- WHN ca. 19990801
994 :type-spec (member :declared :assumed :defined)
996 ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
997 ;; not clear how to generalize the FBOUNDP expression to the
998 ;; cross-compiler. -- WHN 19990606
999 #+sb-xc-host :assumed
1000 #-sb-xc-host (if (fboundp name) :defined :assumed))
1002 ;;; lambda used for inline expansion of this function
1005 :type :inline-expansion
1008 ;;; This specifies whether this function may be expanded inline. If
1009 ;;; null, we don't care.
1016 ;;; a macro-like function which transforms a call to this function
1017 ;;; into some other Lisp form. This expansion is inhibited if inline
1018 ;;; expansion is inhibited
1021 :type :source-transform
1022 :type-spec (or function null))
1024 ;;; the macroexpansion function for this macro
1027 :type :macro-function
1028 :type-spec (or function null)
1031 ;;; the compiler-macroexpansion function for this macro
1034 :type :compiler-macro-function
1035 :type-spec (or function null)
1038 ;;; a function which converts this special form into IR1
1042 :type-spec (or function null))
1044 ;;; a function which gets a chance to do stuff to the IR1 for any call
1045 ;;; to this function.
1048 :type :ir1-transform
1049 :type-spec (or function null))
1051 ;;; If a function is a slot accessor or setter, then this is the class
1052 ;;; that it accesses slots of.
1056 :type-spec (or sb!xc:class null)
1059 ;;; If a function is "known" to the compiler, then this is a
1060 ;;; FUNCTION-INFO structure containing the info used to special-case
1065 :type-spec (or function-info null)
1070 :type :documentation
1071 :type-spec (or string null)
1080 ;;;; definitions for other miscellaneous information
1082 (define-info-class :variable)
1084 ;;; The kind of variable-like thing described.
1088 :type-spec (member :special :constant :global :alien)
1089 :default (if (or (eq (symbol-package name) *keyword-package*)
1090 (member name '(t nil)))
1094 ;;; The declared type for this variable.
1099 :default *universal-type*)
1101 ;;; Where this type and kind information came from.
1105 :type-spec (member :declared :assumed :defined)
1108 ;;; The lisp object which is the value of this constant, if known.
1111 :type :constant-value
1113 :default (if (boundp name)
1114 (values (symbol-value name) t)
1120 :type-spec (or heap-alien-info null)
1125 :type :documentation
1126 :type-spec (or string null)
1129 (define-info-class :type)
1131 ;;; The kind of type described. We return :INSTANCE for standard types that
1132 ;;; are implemented as structures.
1136 :type-spec (member :primitive :defined :instance nil)
1139 ;;; Expander function for a defined type.
1143 :type-spec (or function null)
1148 :type :documentation
1149 :type-spec (or string null))
1151 ;;; function that parses type specifiers into CTYPE structures
1155 :type-spec (or function null)
1158 ;;; If true, then the type coresponding to this name. Note that if
1159 ;;; this is a built-in class with a translation, then this is the
1160 ;;; translation, not the class object. This info type keeps track of
1161 ;;; various atomic types (NIL etc.) and also serves as a cache to
1162 ;;; ensure that common standard types (atomic and otherwise) are only
1167 :type-spec (or ctype null)
1170 ;;; If this is a class name, then the value is a cons (NAME . CLASS),
1171 ;;; where CLASS may be null if the class hasn't been defined yet. Note
1172 ;;; that for built-in classes, the kind may be :PRIMITIVE and not
1173 ;;; :INSTANCE. The the name is in the cons so that we can signal a
1174 ;;; meaningful error if we only have the cons.
1178 :type-spec (or sb!kernel::class-cell null)
1181 ;;; layout for this type being used by the compiler
1184 :type :compiler-layout
1185 :type-spec (or layout null)
1186 :default (let ((class (sb!xc:find-class name nil)))
1187 (when class (class-layout class))))
1189 (define-info-class :typed-structure)
1191 :class :typed-structure
1196 (define-info-class :declaration)
1202 (define-info-class :alien-type)
1206 :type-spec (member :primitive :defined :unknown)
1211 :type-spec (or function null)
1216 :type-spec (or alien-type null)
1221 :type-spec (or alien-type null)
1226 :type-spec (or alien-type null)
1231 :type-spec (or alien-type null)
1234 (define-info-class :setf)
1239 :type-spec (or symbol null)
1244 :type :documentation
1245 :type-spec (or string null)
1251 :type-spec (or function null)
1254 ;;; This is used for storing miscellaneous documentation types. The
1255 ;;; stuff is an alist translating documentation kinds to values.
1256 (define-info-class :random-documentation)
1258 :class :random-documentation
1263 #!-sb-fluid (declaim (freeze-type info-env))
1265 ;;; Now that we have finished initializing *INFO-CLASSES* and
1266 ;;; *INFO-TYPES* (at compile time), generate code to set them at cold
1267 ;;; load time to the same state they have currently.
1269 (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
1270 (setf *info-classes*
1271 (make-hash-table :size #.(hash-table-size *info-classes*)))
1272 (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
1273 (dolist (class-info-name '#.(let ((result nil))
1274 (maphash (lambda (key value)
1275 (declare (ignore value))
1279 (let ((class-info (make-class-info class-info-name)))
1280 (setf (gethash class-info-name *info-classes*)
1282 (/show0 "done with *INFO-CLASSES* initialization")
1283 (/show0 "beginning *INFO-TYPES* initialization")
1288 (let* ((class-info (class-info-or-lose (second x)))
1289 (type-info (make-type-info :name (first x)
1293 (push type-info (class-info-types class-info))
1298 (list (type-info-name info-type)
1299 (class-info-name (type-info-class info-type))
1300 (type-info-number info-type)
1301 (type-info-type info-type))))
1303 (/show0 "done with *INFO-TYPES* initialization"))
1305 ;;; At cold load time, after the INFO-TYPE objects have been created,
1306 ;;; we can set their DEFAULT and TYPE slots.
1309 ,@(reverse *reversed-type-info-init-forms*))))
1312 ;;;; a hack for detecting
1313 ;;;; (DEFUN FOO (X Y)
1315 ;;;; (SETF (BAR A FFH) 12) ; compiles to a call to #'(SETF BAR)
1317 ;;;; (DEFSETF BAR SET-BAR) ; can't influence previous compilation
1319 ;;;; KLUDGE: Arguably it should be another class/type combination in
1320 ;;;; the globaldb. However, IMHO the whole globaldb/fdefinition
1321 ;;;; treatment of SETF functions is a mess which ought to be
1322 ;;;; rewritten, and I'm not inclined to mess with it short of that. So
1323 ;;;; I just put this bag on the side of it instead..
1325 ;;; true for symbols FOO which have been assumed to have '(SETF FOO)
1326 ;;; bound to a function
1327 (defvar *setf-assumed-fboundp*)
1328 (!cold-init-forms (setf *setf-assumed-fboundp* (make-hash-table)))
1330 (!defun-from-collected-cold-init-forms !globaldb-cold-init)