0.6.11.10:
[sbcl.git] / src / compiler / globaldb.lisp
1 ;;;; This file provides a functional interface to global information
2 ;;;; about named things in the system. Information is considered to be
3 ;;;; global if it must persist between invocations of the compiler. The
4 ;;;; use of a functional interface eliminates the need for the compiler
5 ;;;; to worry about the actual representation. This is important, since
6 ;;;; the information may well have several representations.
7 ;;;;
8 ;;;; The database contains arbitrary Lisp values, addressed by a
9 ;;;; 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.
15
16 ;;;; This software is part of the SBCL system. See the README file for
17 ;;;; more information.
18 ;;;;
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.
24
25 (in-package "SB!C")
26
27 (!begin-collecting-cold-init-forms)
28 #!+sb-show (!cold-init-forms (/show0 "early in globaldb.lisp cold init"))
29
30 ;;; The DEFVAR for this appears later.
31 ;;; FIXME: centralize
32 (declaim (special *universal-type*))
33
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.
40 ;;;
41 ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
42 ;;; SXHASH, because
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
48 ;;;      because
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.
52 ;;;
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.)
62         ((symbolp x)
63          (symbol-hash x))
64         #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
65         ((and (listp x)
66               (eq (first x) 'setf)
67               (let ((rest (rest x)))
68                 (and (symbolp (car rest))
69                      (null (cdr rest)))))
70          (logxor (symbol-hash (second x))
71                  110680597))
72         (t (sxhash x))))
73
74 ;;; Given any non-negative integer, return a prime number >= to it.
75 ;;;
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.
84 (defun primify (x)
85   (declare (type unsigned-byte x))
86   (do ((n (logior x 1) (+ n 2)))
87       ((sb!sys:positive-primep n)
88        n)))
89 \f
90 ;;;; info classes, info types, and type numbers, part I: what's needed
91 ;;;; not only at compile time but also at run time
92
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
99 ;;;; process.
100
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))
105
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)
118
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             (:copier nil))
126   ;; name of this class
127   (name nil :type keyword :read-only t)
128   ;; List of Type-Info structures for each type in this class.
129   (types () :type list))
130
131 ;;; a map from type numbers to TYPE-INFO objects. There is one type
132 ;;; number for each defined CLASS/TYPE pair.
133 ;;;
134 ;;; We build its value at compile time (with calls to
135 ;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
136 ;;; value, and arrange for that code to be called in cold load.
137 (defvar *info-types*)
138 (declaim (type simple-vector *info-types*))
139 (eval-when (:compile-toplevel :execute)
140   (setf *info-types*
141         (make-array (ash 1 type-number-bits) :initial-element nil)))
142
143 (defstruct (type-info
144             #-no-ansi-print-object
145             (:print-object (lambda (x s)
146                              (print-unreadable-object (x s)
147                                (format s
148                                        "~S ~S, Number = ~D"
149                                        (class-info-name (type-info-class x))
150                                        (type-info-name x)
151                                        (type-info-number x)))))
152             (:copier nil))
153   ;; the name of this type
154   (name (required-argument) :type keyword)
155   ;; this type's class
156   (class (required-argument) :type class-info)
157   ;; a number that uniquely identifies this type (and implicitly its class)
158   (number (required-argument) :type type-number)
159   ;; a type specifier which info of this type must satisfy
160   (type nil :type t)
161   ;; a function called when there is no information of this type
162   (default (lambda () (error "type not defined yet")) :type function))
163
164 ;;; a map from class names to CLASS-INFO structures
165 ;;;
166 ;;; We build the value for this at compile time (with calls to
167 ;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
168 ;;; value, and arrange for that code to be called in cold load.
169 (defvar *info-classes*)
170 (declaim (hash-table *info-classes*))
171 (eval-when (:compile-toplevel :execute)
172   (setf *info-classes* (make-hash-table)))
173
174 ;;; If Name is the name of a type in Class, then return the TYPE-INFO,
175 ;;; otherwise NIL.
176 (defun find-type-info (name class)
177   (declare (type keyword name) (type class-info class))
178   (dolist (type (class-info-types class) nil)
179     (when (eq (type-info-name type) name)
180       (return type))))
181
182 ;;; Return the info structure for an info class or type, or die trying.
183 (declaim (ftype (function (keyword) class-info) class-info-or-lose))
184 (defun class-info-or-lose (class)
185   (declare (type keyword class))
186   (or (gethash class *info-classes*)
187       (error "~S is not a defined info class." class)))
188 (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
189 (defun type-info-or-lose (class type)
190   (or (find-type-info type (class-info-or-lose class))
191       (error "~S is not a defined info type." type)))
192
193 ) ; EVAL-WHEN
194 \f
195 ;;;; info classes, info types, and type numbers, part II: what's
196 ;;;; needed only at compile time, not at run time
197
198 ;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS
199 ;;; and the calls to it) could/should go in a separate file,
200 ;;; perhaps info-classes.lisp?
201
202 (eval-when (:compile-toplevel :execute)
203
204 ;;; Set up the data structures to support an info class. We make sure
205 ;;; that the class exists at compile time so that macros can use it,
206 ;;; but don't actually store the init function until load time so that
207 ;;; we don't break the running compiler.
208 (#+sb-xc-host defmacro
209  #-sb-xc-host sb!xc:defmacro
210      define-info-class (class)
211   #!+sb-doc
212   "Define-Info-Class Class
213   Define a new class of global information."
214   (declare (type keyword class))
215   `(progn
216      ;; (We don't need to evaluate this at load time, compile time is
217      ;; enough. There's special logic elsewhere which deals with cold
218      ;; load initialization by inspecting the info class data
219      ;; structures at compile time and generating code to recreate
220      ;; those data structures.)
221      (eval-when (:compile-toplevel :execute)
222        (unless (gethash ,class *info-classes*)
223          (setf (gethash ,class *info-classes*) (make-class-info ,class))))
224      ,class))
225
226 ;;; Find a type number not already in use by looking for a null entry
227 ;;; in *INFO-TYPES*.
228 (defun find-unused-type-number ()
229   (or (position nil *info-types*)
230       (error "no more INFO type numbers available")))
231
232 ;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO
233 ;;; objects, accumulated during compilation and eventually converted
234 ;;; into a function to be called at cold load time after the
235 ;;; appropriate TYPE-INFO objects have been created
236 ;;;
237 ;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
238 ;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery
239 ;;; here. The problem is that the natural order in which the
240 ;;; default-slot-initialization forms are generated relative to the
241 ;;; order in which the TYPE-INFO-creation forms are generated doesn't
242 ;;; match the relative order in which the forms need to be executed at
243 ;;; cold load time.
244 (defparameter *reversed-type-info-init-forms* nil)
245
246 ;;; The main thing we do is determine the type's number. We need to do
247 ;;; this at macroexpansion time, since both the COMPILE and LOAD time
248 ;;; calls to %DEFINE-INFO-TYPE must use the same type number.
249 (#+sb-xc-host defmacro
250  #-sb-xc-host sb!xc:defmacro
251     define-info-type (&key (class (required-argument))
252                            (type (required-argument))
253                            (type-spec (required-argument))
254                            default)
255   #!+sb-doc
256   "Define-Info-Type Class Type default Type-Spec
257   Define a new type of global information for Class. Type is the name
258   of the type, Default is the value for that type when it hasn't been set, and
259   Type-Spec is a type-specifier which values of the type must satisfy. The
260   default expression is evaluated each time the information is needed, with
261   Name bound to the name for which the information is being looked up. If the
262   default evaluates to something with the second value true, then the second
263   value of Info will also be true."
264   (declare (type keyword class type))
265   `(progn
266      (eval-when (:compile-toplevel :execute)
267        ;; At compile time, ensure that the type number exists. It will
268        ;; need to be forced to exist at cold load time, too, but
269        ;; that's not handled here; it's handled by later code which
270        ;; looks at the compile time state and generates code to
271        ;; replicate it at cold load time.
272        (let* ((class-info (class-info-or-lose ',class))
273               (old-type-info (find-type-info ',type class-info)))
274          (unless old-type-info
275            (let* ((new-type-number (find-unused-type-number))
276                   (new-type-info
277                    (make-type-info :name ',type
278                                    :class class-info
279                                    :number new-type-number)))
280              (setf (aref *info-types* new-type-number) new-type-info)
281              (push new-type-info (class-info-types class-info)))))
282        ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
283        ;; at cold load time. (They can't very well be set at
284        ;; cross-compile time, since they differ between the
285        ;; cross-compiler and the target. The DEFAULT slot values
286        ;; differ because they're compiled closures, and the TYPE slot
287        ;; values differ in the use of SB!XC symbols instead of CL
288        ;; symbols.)
289        (push `(let ((type-info (type-info-or-lose ,',class ,',type)))
290                 (setf (type-info-default type-info)
291                        ;; FIXME: This code is sort of nasty. It would
292                        ;; be cleaner if DEFAULT accepted a real
293                        ;; function, instead of accepting a statement
294                        ;; which will be turned into a lambda assuming
295                        ;; that the argument name is NAME. It might
296                        ;; even be more microefficient, too, since many
297                        ;; DEFAULTs could be implemented as (CONSTANTLY
298                        ;; NIL) instead of full-blown (LAMBDA (X) NIL).
299                        (lambda (name)
300                          (declare (ignorable name))
301                          ,',default))
302                 (setf (type-info-type type-info) ',',type-spec))
303              *reversed-type-info-init-forms*))
304      ',type))
305
306 ) ; EVAL-WHEN
307 \f
308 ;;;; generic info environments
309
310 ;;; Note: the CACHE-NAME slot is deliberately not shared for
311 ;;; bootstrapping reasons. If we access with accessors for the exact
312 ;;; type, then the inline type check will win. If the inline check
313 ;;; didn't win, we would try to use the type system before it was
314 ;;; properly initialized.
315 (defstruct (info-env (:constructor nil)
316                      (:copier nil))
317   ;; some string describing what is in this environment, for
318   ;; printing/debugging purposes only
319   (name (required-argument) :type string))
320 (def!method print-object ((x info-env) stream)
321   (print-unreadable-object (x stream :type t)
322     (prin1 (info-env-name x) stream)))
323 \f
324 ;;;; generic interfaces
325
326 ;;; FIXME: used only in this file, needn't be in runtime
327 (defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
328                         (type-number (gensym)) (value (gensym)) known-volatile)
329                    &body body)
330   #!+sb-doc
331   "DO-INFO (Env &Key Name Class Type Value) Form*
332   Iterate over all the values stored in the Info-Env Env. Name is bound to
333   the entry's name, Class and Type are bound to the class and type
334   (represented as keywords), and Value is bound to the entry's value."
335   (once-only ((n-env env))
336     (if known-volatile
337         (do-volatile-info name class type type-number value n-env body)
338         `(if (typep ,n-env 'volatile-info-env)
339              ,(do-volatile-info name class type type-number value n-env body)
340              ,(do-compact-info name class type type-number value
341                                n-env body)))))
342
343 (eval-when (:compile-toplevel :load-toplevel :execute)
344
345 ;;; Return code to iterate over a compact info environment.
346 (defun do-compact-info (name-var class-var type-var type-number-var value-var
347                                  n-env body)
348   (let ((n-index (gensym))
349         (n-type (gensym))
350         (punt (gensym)))
351     (once-only ((n-table `(compact-info-env-table ,n-env))
352                 (n-entries-index `(compact-info-env-index ,n-env))
353                 (n-entries `(compact-info-env-entries ,n-env))
354                 (n-entries-info `(compact-info-env-entries-info ,n-env))
355                 (n-info-types '*info-types*))
356       `(dotimes (,n-index (length ,n-table))
357          (declare (type index ,n-index))
358          (block ,PUNT
359            (let ((,name-var (svref ,n-table ,n-index)))
360              (unless (eql ,name-var 0)
361                (do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
362                                        (1+ ,n-type)))
363                              (nil)
364                  (declare (type index ,n-type))
365                  ,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
366                     `(let ((,type-number-var
367                             (logand ,n-info compact-info-entry-type-mask)))
368                        ,(once-only ((n-type-info
369                                      `(svref ,n-info-types
370                                              ,type-number-var)))
371                           `(let ((,type-var (type-info-name ,n-type-info))
372                                  (,class-var (class-info-name
373                                               (type-info-class ,n-type-info)))
374                                  (,value-var (svref ,n-entries ,n-type)))
375                              (declare (ignorable ,type-var ,class-var
376                                                  ,value-var))
377                              ,@body
378                              (unless (zerop (logand ,n-info
379                                                     compact-info-entry-last))
380                                (return-from ,PUNT))))))))))))))
381
382 ;;; Return code to iterate over a volatile info environment.
383 (defun do-volatile-info (name-var class-var type-var type-number-var value-var
384                                   n-env body)
385   (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
386     (once-only ((n-table `(volatile-info-env-table ,n-env))
387                 (n-info-types '*info-types*))
388       `(dotimes (,n-index (length ,n-table))
389          (declare (type index ,n-index))
390          (do-anonymous ((,n-names (svref ,n-table ,n-index)
391                                   (cdr ,n-names)))
392                        ((null ,n-names))
393            (let ((,name-var (caar ,n-names)))
394              (declare (ignorable ,name-var))
395              (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
396                            ((null ,n-types))
397                (let ((,type-number-var (caar ,n-types)))
398                  ,(once-only ((n-type `(svref ,n-info-types
399                                               ,type-number-var)))
400                     `(let ((,type-var (type-info-name ,n-type))
401                            (,class-var (class-info-name
402                                         (type-info-class ,n-type)))
403                            (,value-var (cdar ,n-types)))
404                        (declare (ignorable ,type-var ,class-var ,value-var))
405                        ,@body))))))))))
406
407 ) ; EVAL-WHEN
408 \f
409 ;;;; INFO cache
410
411 ;;;; We use a hash cache to cache name X type => value for the current
412 ;;;; value of *INFO-ENVIRONMENT*. This is in addition to the
413 ;;;; per-environment caching of name => types.
414
415 ;;; The value of *INFO-ENVIRONMENT* that has cached values.
416 ;;; *INFO-ENVIRONMENT* should never be destructively modified, so if
417 ;;; it is EQ to this, then the cache is valid.
418 (defvar *cached-info-environment*)
419 (!cold-init-forms
420   (setf *cached-info-environment* nil))
421
422 ;;; the hash function used for the INFO cache
423 #!-sb-fluid (declaim (inline info-cache-hash))
424 (defun info-cache-hash (name type)
425   (logand
426     (the fixnum
427          (logxor (globaldb-sxhashoid name)
428                  (ash (the fixnum type) 7)))
429     #x3FF))
430
431 (!cold-init-forms
432   (/show0 "before initialization of INFO hash cache"))
433 (define-hash-cache info ((name eq) (type eq))
434   :values 2
435   :hash-function info-cache-hash
436   :hash-bits 10
437   :default (values nil :empty)
438   :init-wrapper !cold-init-forms)
439 (!cold-init-forms
440   (/show0 "clearing INFO hash cache")
441   (info-cache-clear)
442   (/show0 "done clearing INFO hash cache"))
443
444 ;;; If the info cache is invalid, then clear it.
445 #!-sb-fluid (declaim (inline clear-invalid-info-cache))
446 (defun clear-invalid-info-cache ()
447   ;; Unless the cache is valid..
448   (unless (eq *info-environment* *cached-info-environment*)
449     (;; In the target Lisp, this should be done without interrupts,
450      ;; but in the host Lisp when cross-compiling, we don't need to
451      ;; sweat it, since no affected-by-GC hashes should be used when
452      ;; running under the host Lisp (since that's non-portable) and
453      ;; since only one thread should be used when running under the
454      ;; host Lisp (because multiple threads are non-portable too).
455      #-sb-xc-host without-interrupts
456      #+sb-xc-host progn
457       (info-cache-clear)
458       (setq *cached-info-environment* *info-environment*))))
459 \f
460 ;;;; compact info environments
461
462 ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
463 (defconstant compact-info-env-entries-bits 16)
464 (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
465
466 ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO
467 (deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))
468
469 ;;; This is an open hashtable with rehashing. Since modification is
470 ;;; not allowed, we don't have to worry about deleted entries. We
471 ;;; indirect through a parallel vector to find the index in the
472 ;;; ENTRIES at which the entries for a given name starts.
473 (defstruct (compact-info-env (:include info-env)
474                              #-sb-xc-host (:pure :substructure)
475                              (:copier nil))
476   ;; If this value is EQ to the name we want to look up, then the
477   ;; cache hit function can be called instead of the lookup function.
478   (cache-name 0)
479   ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has
480   ;; no entries.
481   (cache-index nil :type (or compact-info-entries-index null))
482   ;; hashtable of the names in this environment. If a bucket is
483   ;; unused, it is 0.
484   (table (required-argument) :type simple-vector)
485   ;; an indirection vector parallel to TABLE, translating indices in
486   ;; TABLE to the start of the ENTRIES for that name. Unused entries
487   ;; are undefined.
488   (index (required-argument)
489          :type (simple-array compact-info-entries-index (*)))
490   ;; a vector contining in contiguous ranges the values of for all the
491   ;; types of info for each name.
492   (entries (required-argument) :type simple-vector)
493   ;; Vector parallel to ENTRIES, indicating the type number for the value
494   ;; stored in that location and whether this location is the last type of info
495   ;; stored for this name. The type number is in the low TYPE-NUMBER-BITS
496   ;; bits, and the next bit is set if this is the last entry.
497   (entries-info (required-argument)
498                 :type (simple-array compact-info-entry (*))))
499
500 (defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
501 (defconstant compact-info-entry-last (ash 1 type-number-bits))
502
503 ;;; Return the value of the type corresponding to Number for the currently
504 ;;; cached name in Env.
505 #!-sb-fluid (declaim (inline compact-info-cache-hit))
506 (defun compact-info-cache-hit (env number)
507   (declare (type compact-info-env env) (type type-number number))
508   (let ((entries-info (compact-info-env-entries-info env))
509         (index (compact-info-env-cache-index env)))
510     (if index
511         (do ((index index (1+ index)))
512             (nil)
513           (declare (type index index))
514           (let ((info (aref entries-info index)))
515             (when (= (logand info compact-info-entry-type-mask) number)
516               (return (values (svref (compact-info-env-entries env) index)
517                               t)))
518             (unless (zerop (logand compact-info-entry-last info))
519               (return (values nil nil)))))
520         (values nil nil))))
521
522 ;;; Encache Name in the compact environment Env. Hash is the
523 ;;; GLOBALDB-SXHASHOID of Name.
524 (defun compact-info-lookup (env name hash)
525   (declare (type compact-info-env env) (type index hash))
526   (let* ((table (compact-info-env-table env))
527          (len (length table))
528          (len-2 (- len 2))
529          (hash2 (- len-2 (rem hash len-2))))
530     (declare (type index len-2 hash2))
531     (macrolet ((lookup (test)
532                  `(do ((probe (rem hash len)
533                               (let ((new (+ probe hash2)))
534                                 (declare (type index new))
535                                 ;; same as (mod new len), but faster.
536                                 (if (>= new len)
537                                     (the index (- new len))
538                                     new))))
539                       (nil)
540                     (let ((entry (svref table probe)))
541                       (when (eql entry 0)
542                         (return nil))
543                       (when (,test entry name)
544                         (return (aref (compact-info-env-index env)
545                                       probe)))))))
546       (setf (compact-info-env-cache-index env)
547             (if (symbolp name)
548                 (lookup eq)
549                 (lookup equal)))
550       (setf (compact-info-env-cache-name env) name)))
551
552   (values))
553
554 ;;; the exact density (modulo rounding) of the hashtable in a compact
555 ;;; info environment in names/bucket
556 (defconstant compact-info-environment-density 65)
557
558 ;;; Iterate over the environment once to find out how many names and entries
559 ;;; it has, then build the result. This code assumes that all the entries for
560 ;;; a name well be iterated over contiguously, which holds true for the
561 ;;; implementation of iteration over both kinds of environments.
562 ;;;
563 ;;; When building the table, we sort the entries by POINTER< in an attempt
564 ;;; to preserve any VM locality present in the original load order, rather than
565 ;;; randomizing with the original hash function.
566 (defun compact-info-environment (env &key (name (info-env-name env)))
567   #!+sb-doc
568   "Return a new compact info environment that holds the same information as
569   Env."
570   (let ((name-count 0)
571         (prev-name 0)
572         (entry-count 0))
573     (collect ((names))
574       (let ((types ()))
575         (do-info (env :name name :type-number num :value value)
576           (unless (eq name prev-name)
577             (incf name-count)
578             (unless (eql prev-name 0)
579               (names (cons prev-name types)))
580             (setq prev-name name)
581             (setq types ()))
582           (incf entry-count)
583           (push (cons num value) types))
584         (unless (eql prev-name 0)
585           (names (cons prev-name types))))
586
587       (let* ((table-size (primify
588                           (+ (truncate (* name-count 100)
589                                        compact-info-environment-density)
590                              3)))
591              (table (make-array table-size :initial-element 0))
592              (index (make-array table-size
593                                 :element-type 'compact-info-entries-index))
594              (entries (make-array entry-count))
595              (entries-info (make-array entry-count
596                                        :element-type 'compact-info-entry))
597              (sorted (sort (names)
598                            #+sb-xc-host #'<
599                            #-sb-xc-host (lambda (x y)
600                                           ;; FIXME: What's going on here?
601                                           (< (%primitive make-fixnum x)
602                                              (%primitive make-fixnum y))))))
603         (let ((entries-idx 0))
604           (dolist (types sorted)
605             (let* ((name (first types))
606                    (hash (globaldb-sxhashoid name))
607                    (len-2 (- table-size 2))
608                    (hash2 (- len-2 (rem hash len-2))))
609               (do ((probe (rem hash table-size)
610                           (rem (+ probe hash2) table-size)))
611                   (nil)
612                 (let ((entry (svref table probe)))
613                   (when (eql entry 0)
614                     (setf (svref table probe) name)
615                     (setf (aref index probe) entries-idx)
616                     (return))
617                   (assert (not (equal entry name))))))
618
619             (unless (zerop entries-idx)
620               (setf (aref entries-info (1- entries-idx))
621                     (logior (aref entries-info (1- entries-idx))
622                             compact-info-entry-last)))
623
624             (loop for (num . value) in (rest types) do
625               (setf (aref entries-info entries-idx) num)
626               (setf (aref entries entries-idx) value)
627               (incf entries-idx)))
628
629           (unless (zerop entry-count)
630             (setf (aref entries-info (1- entry-count))
631                   (logior (aref entries-info (1- entry-count))
632                           compact-info-entry-last)))
633
634           (make-compact-info-env :name name
635                                  :table table
636                                  :index index
637                                  :entries entries
638                                  :entries-info entries-info))))))
639 \f
640 ;;;; volatile environments
641
642 ;;; This is a closed hashtable, with the bucket being computed by
643 ;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size.
644 (defstruct (volatile-info-env (:include info-env)
645                               (:copier nil))
646   ;; If this value is EQ to the name we want to look up, then the
647   ;; cache hit function can be called instead of the lookup function.
648   (cache-name 0)
649   ;; the alist translating type numbers to values for the currently
650   ;; cached name
651   (cache-types nil :type list)
652   ;; vector of alists of alists of the form:
653   ;;    ((Name . ((Type-Number . Value) ...) ...)
654   (table (required-argument) :type simple-vector)
655   ;; the number of distinct names currently in this table. Each name
656   ;; may have multiple entries, since there can be many types of info.
657   (count 0 :type index)
658   ;; the number of names at which we should grow the table and rehash
659   (threshold 0 :type index))
660
661 ;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
662 #!-sb-fluid (declaim (inline volatile-info-cache-hit))
663 (defun volatile-info-cache-hit (env number)
664   (declare (type volatile-info-env env) (type type-number number))
665   (dolist (type (volatile-info-env-cache-types env) (values nil nil))
666     (when (eql (car type) number)
667       (return (values (cdr type) t)))))
668
669 ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
670 (defun volatile-info-lookup (env name hash)
671   (declare (type volatile-info-env env) (type index hash))
672   (let ((table (volatile-info-env-table env)))
673     (macrolet ((lookup (test)
674                  `(dolist (entry (svref table (mod hash (length table))) ())
675                     (when (,test (car entry) name)
676                       (return (cdr entry))))))
677       (setf (volatile-info-env-cache-types env)
678             (if (symbolp name)
679                 (lookup eq)
680                 (lookup equal)))
681       (setf (volatile-info-env-cache-name env) name)))
682
683   (values))
684
685 ;;; Given a volatile environment Env, bind Table-Var the environment's table
686 ;;; and Index-Var to the index of Name's bucket in the table. We also flush
687 ;;; the cache so that things will be consistent if body modifies something.
688 (eval-when (:compile-toplevel :execute)
689   (#+sb-xc-host cl:defmacro
690    #-sb-xc-host sb!xc:defmacro
691       with-info-bucket ((table-var index-var name env) &body body)
692     (once-only ((n-name name)
693                 (n-env env))
694       `(progn
695          (setf (volatile-info-env-cache-name ,n-env) 0)
696          (let* ((,table-var (volatile-info-env-table ,n-env))
697                 (,index-var (mod (globaldb-sxhashoid ,n-name)
698                                  (length ,table-var))))
699            ,@body)))))
700
701 ;;; Get the info environment that we use for write/modification operations.
702 ;;; This is always the first environment in the list, and must be a
703 ;;; VOLATILE-INFO-ENV.
704 #!-sb-fluid (declaim (inline get-write-info-env))
705 (defun get-write-info-env (&optional (env-list *info-environment*))
706   (let ((env (car env-list)))
707     (unless env
708       (error "no info environment?"))
709     (unless (typep env 'volatile-info-env)
710       (error "cannot modify this environment: ~S" env))
711     (the volatile-info-env env)))
712
713 ;;; If Name is already present in the table, then just create or
714 ;;; modify the specified type. Otherwise, add the new name and type,
715 ;;; checking for rehashing.
716 ;;;
717 ;;; We rehash by making a new larger environment, copying all of the
718 ;;; entries into it, then clobbering the old environment with the new
719 ;;; environment's table. We clear the old table to prevent it from
720 ;;; holding onto garbage if it is statically allocated.
721 ;;;
722 ;;; We return the new value so that this can be conveniently used in a
723 ;;; SETF function.
724 (defun set-info-value (name0 type new-value
725                              &optional (env (get-write-info-env)))
726   (declare (type type-number type) (type volatile-info-env env)
727            (inline assoc))
728   (let ((name (uncross name0)))
729     (when (eql name 0)
730       (error "0 is not a legal INFO name."))
731     ;; We don't enter the value in the cache because we don't know that this
732     ;; info-environment is part of *cached-info-environment*.
733     (info-cache-enter name type nil :empty)
734     (with-info-bucket (table index name env)
735       (let ((types (if (symbolp name)
736                        (assoc name (svref table index) :test #'eq)
737                        (assoc name (svref table index) :test #'equal))))
738         (cond
739          (types
740           (let ((value (assoc type (cdr types))))
741             (if value
742                 (setf (cdr value) new-value)
743                 (push (cons type new-value) (cdr types)))))
744          (t
745           (push (cons name (list (cons type new-value)))
746                 (svref table index))
747
748           (let ((count (incf (volatile-info-env-count env))))
749             (when (>= count (volatile-info-env-threshold env))
750               (let ((new (make-info-environment :size (* count 2))))
751                 (do-info (env :name entry-name :type-number entry-num
752                               :value entry-val :known-volatile t)
753                          (set-info-value entry-name entry-num entry-val new))
754                 (fill (volatile-info-env-table env) nil)
755                 (setf (volatile-info-env-table env)
756                       (volatile-info-env-table new))
757                 (setf (volatile-info-env-threshold env)
758                       (volatile-info-env-threshold new)))))))))
759     new-value))
760
761 ;;; FIXME: It should be possible to eliminate the hairy compiler macros below
762 ;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro
763 ;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the
764 ;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE
765 ;;; foldable.)
766
767 ;;; INFO is the standard way to access the database. It's settable.
768 (defun info (class type name &optional (env-list nil env-list-p))
769   #!+sb-doc
770   "Return the information of the specified TYPE and CLASS for NAME.
771    The second value returned is true if there is any such information
772    recorded. If there is no information, the first value returned is
773    the default and the second value returned is NIL."
774   ;; FIXME: At some point check systematically to make sure that the system
775   ;; doesn't do any full calls to INFO or (SETF INFO), or at least none in any
776   ;; inner loops.
777   (let ((info (type-info-or-lose class type)))
778     (if env-list-p
779       (get-info-value name (type-info-number info) env-list)
780       (get-info-value name (type-info-number info)))))
781 #!-sb-fluid
782 (define-compiler-macro info
783   (&whole whole class type name &optional (env-list nil env-list-p))
784   ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
785   ;; can resolve it much more efficiently than the general case.
786   (if (and (constantp class) (constantp type))
787       (let ((info (type-info-or-lose class type)))
788         `(the ,(type-info-type info)
789            (get-info-value ,name
790                            ,(type-info-number info)
791                            ,@(when env-list-p `(,env-list)))))
792       whole))
793 (defun (setf info) (new-value
794                     class
795                     type
796                     name
797                     &optional (env-list nil env-list-p))
798   (let* ((info (type-info-or-lose class type))
799          (tin (type-info-number info)))
800     (if env-list-p
801       (set-info-value name
802                       tin
803                       new-value
804                       (get-write-info-env env-list))
805       (set-info-value name
806                       tin
807                       new-value)))
808   new-value)
809 ;;; FIXME: We'd like to do this, but Python doesn't support
810 ;;; compiler macros and it's hard to change it so that it does.
811 ;;; It might make more sense to just convert INFO :FOO :BAR into
812 ;;; an ordinary function, so that instead of calling INFO :FOO :BAR
813 ;;; you call e.g. INFO%FOO%BAR. Then dynamic linking could be handled
814 ;;; by the ordinary Lisp mechanisms and we wouldn't have to maintain
815 ;;; all this cruft..
816 #|
817 #!-sb-fluid
818 (progn
819   (define-compiler-macro (setf info) (&whole whole
820                                       new-value
821                                       class
822                                       type
823                                       name
824                                       &optional (env-list nil env-list-p))
825     ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
826     ;; can resolve it much more efficiently than the general case.
827     (if (and (constantp class) (constantp type))
828         (let* ((info (type-info-or-lose class type))
829                (tin (type-info-number info)))
830           (if env-list-p
831               `(set-info-value ,name
832                                ,tin
833                                ,new-value
834                                (get-write-info-env ,env-list))
835               `(set-info-value ,name
836                                ,tin
837                                ,new-value)))
838         whole)))
839 |#
840
841 ;;; the maximum density of the hashtable in a volatile env (in
842 ;;; names/bucket)
843 ;;;
844 ;;; FIXME: actually seems to be measured in percent, should be
845 ;;; converted to be measured in names/bucket
846 (defconstant volatile-info-environment-density 50)
847
848 ;;; Make a new volatile environment of the specified size.
849 (defun make-info-environment (&key (size 42) (name "Unknown"))
850   (declare (type (integer 1) size))
851   (let ((table-size (primify (truncate (* size 100)
852                                        volatile-info-environment-density))))
853     (make-volatile-info-env :name name
854                             :table (make-array table-size :initial-element nil)
855                             :threshold size)))
856
857 (defun clear-info (class type name)
858   #!+sb-doc
859   "Clear the information of the specified Type and Class for Name in the
860   current environment, allowing any inherited info to become visible. We
861   return true if there was any info."
862   (let ((info (type-info-or-lose class type)))
863     (clear-info-value name (type-info-number info))))
864 #!-sb-fluid
865 (define-compiler-macro clear-info (&whole whole class type name)
866   ;; Constant CLASS and TYPE is an overwhelmingly common special case, and
867   ;; we can resolve it much more efficiently than the general case.
868   (if (and (keywordp class) (keywordp type))
869     (let ((info (type-info-or-lose class type)))
870       `(clear-info-value ,name ,(type-info-number info)))
871     whole))
872 (defun clear-info-value (name type)
873   (declare (type type-number type) (inline assoc))
874   (clear-invalid-info-cache)
875   (info-cache-enter name type nil :empty)
876   (with-info-bucket (table index name (get-write-info-env))
877     (let ((types (assoc name (svref table index) :test #'equal)))
878       (when (and types
879                  (assoc type (cdr types)))
880         (setf (cdr types)
881               (delete type (cdr types) :key #'car))
882         t))))
883 \f
884 ;;;; *INFO-ENVIRONMENT*
885
886 ;;; We do info access relative to the current *INFO-ENVIRONMENT*, a
887 ;;; list of INFO-ENVIRONMENT structures.
888 (defvar *info-environment*)
889 (declaim (type list *info-environment*))
890 (!cold-init-forms
891   (setq *info-environment*
892         (list (make-info-environment :name "initial global")))
893   (/show0 "done setting *INFO-ENVIRONMENT*"))
894 ;;; FIXME: should perhaps be *INFO-ENV-LIST*. And rename
895 ;;; all FOO-INFO-ENVIRONMENT-BAR stuff to FOO-INFO-ENV-BAR.
896 \f
897 ;;;; GET-INFO-VALUE
898
899 ;;; Check whether the name and type is in our cache, if so return it.
900 ;;; Otherwise, search for the value and encache it.
901 ;;;
902 ;;; Return the value from the first environment which has it defined, or
903 ;;; return the default if none does. We have a cache for the last name looked
904 ;;; up in each environment. We don't compute the hash until the first time the
905 ;;; cache misses. When the cache does miss, we invalidate it before calling the
906 ;;; lookup routine to eliminate the possiblity of the cache being partially
907 ;;; updated if the lookup is interrupted.
908 (defun get-info-value (name0 type &optional (env-list nil env-list-p))
909   (declare (type type-number type))
910   (let ((name (uncross name0)))
911     (flet ((lookup-ignoring-global-cache (env-list)
912              (let ((hash nil))
913                (dolist (env env-list
914                             (multiple-value-bind (val winp)
915                                 (funcall (type-info-default
916                                           (svref *info-types* type))
917                                          name)
918                               (values val winp)))
919                  (macrolet ((frob (lookup cache slot)
920                               `(progn
921                                  (unless (eq name (,slot env))
922                                    (unless hash
923                                      (setq hash (globaldb-sxhashoid name)))
924                                    (setf (,slot env) 0)
925                                    (,lookup env name hash))
926                                  (multiple-value-bind (value winp)
927                                      (,cache env type)
928                                    (when winp (return (values value t)))))))
929                    (if (typep env 'volatile-info-env)
930                    (frob volatile-info-lookup volatile-info-cache-hit
931                          volatile-info-env-cache-name)
932                    (frob compact-info-lookup compact-info-cache-hit
933                          compact-info-env-cache-name)))))))
934       (cond (env-list-p
935              (lookup-ignoring-global-cache env-list))
936             (t
937              (clear-invalid-info-cache)
938              (multiple-value-bind (val winp) (info-cache-lookup name type)
939                (if (eq winp :empty)
940                    (multiple-value-bind (val winp)
941                        (lookup-ignoring-global-cache *info-environment*)
942                      (info-cache-enter name type val winp)
943                      (values val winp))
944                    (values val winp))))))))
945 \f
946 ;;;; definitions for function information
947
948 (define-info-class :function)
949
950 ;;; the kind of functional object being described. If null, NAME isn't
951 ;;; a known functional object.
952 (define-info-type
953   :class :function
954   :type :kind
955   :type-spec (member nil :function :macro :special-form)
956   ;; I'm a little confused what the correct behavior of this default
957   ;; is. It's not clear how to generalize the FBOUNDP expression to
958   ;; the cross-compiler. As far as I can tell, NIL is a safe default
959   ;; -- it might keep the compiler from making some valid
960   ;; optimization, but it shouldn't produce incorrect code. -- WHN
961   ;; 19990330
962   :default
963   #+sb-xc-host nil
964   #-sb-xc-host (if (fboundp name) :function nil))
965
966 ;;; The type specifier for this function.
967 (define-info-type
968   :class :function
969   :type :type
970   :type-spec ctype
971   ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
972   ;; not clear how to generalize the FBOUNDP expression to the
973   ;; cross-compiler. -- WHN 19990330
974   :default
975   #+sb-xc-host (specifier-type 'function)
976   #-sb-xc-host (if (fboundp name)
977                    (extract-function-type (fdefinition name))
978                    (specifier-type 'function)))
979
980 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
981 ;;; due to not having a declaration or definition
982 (define-info-type
983   :class :function
984   :type :assumed-type
985   :type-spec (or approximate-function-type null))
986
987 ;;; where this information came from:
988 ;;;  :DECLARED = from a declaration.
989 ;;;  :ASSUMED  = from uses of the object.
990 ;;;  :DEFINED  = from examination of the definition.
991 ;;; FIXME: The :DEFINED assumption that the definition won't change
992 ;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way
993 ;;; which violates its "type declarations are assertions" principle,
994 ;;; and SBCL has inherited that behavior. It would be really good to
995 ;;; fix the compiler so that it tests the return types of functions..
996 ;;; -- WHN ca. 19990801
997 (define-info-type
998   :class :function
999   :type :where-from
1000   :type-spec (member :declared :assumed :defined)
1001   :default
1002   ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
1003   ;; not clear how to generalize the FBOUNDP expression to the
1004   ;; cross-compiler. -- WHN 19990606
1005   #+sb-xc-host :assumed
1006   #-sb-xc-host (if (fboundp name) :defined :assumed))
1007
1008 ;;; lambda used for inline expansion of this function
1009 (define-info-type
1010   :class :function
1011   :type :inline-expansion
1012   :type-spec list)
1013
1014 ;;; This specifies whether this function may be expanded inline. If
1015 ;;; null, we don't care.
1016 (define-info-type
1017   :class :function
1018   :type :inlinep
1019   :type-spec inlinep
1020   :default nil)
1021
1022 ;;; a macro-like function which transforms a call to this function
1023 ;;; into some other Lisp form. This expansion is inhibited if inline
1024 ;;; expansion is inhibited
1025 (define-info-type
1026   :class :function
1027   :type :source-transform
1028   :type-spec (or function null))
1029
1030 ;;; the macroexpansion function for this macro
1031 (define-info-type
1032   :class :function
1033   :type :macro-function
1034   :type-spec (or function null)
1035   :default nil)
1036
1037 ;;; the compiler-macroexpansion function for this macro
1038 (define-info-type
1039   :class :function
1040   :type :compiler-macro-function
1041   :type-spec (or function null)
1042   :default nil)
1043
1044 ;;; a function which converts this special form into IR1
1045 (define-info-type
1046   :class :function
1047   :type :ir1-convert
1048   :type-spec (or function null))
1049
1050 ;;; a function which gets a chance to do stuff to the IR1 for any call
1051 ;;; to this function.
1052 (define-info-type
1053   :class :function
1054   :type :ir1-transform
1055   :type-spec (or function null))
1056
1057 ;;; If a function is a slot accessor or setter, then this is the class
1058 ;;; that it accesses slots of.
1059 (define-info-type
1060   :class :function
1061   :type :accessor-for
1062   :type-spec (or sb!xc:class null)
1063   :default nil)
1064
1065 ;;; If a function is "known" to the compiler, then this is a
1066 ;;; FUNCTION-INFO structure containing the info used to special-case
1067 ;;; compilation.
1068 (define-info-type
1069   :class :function
1070   :type :info
1071   :type-spec (or function-info null)
1072   :default nil)
1073
1074 (define-info-type
1075   :class :function
1076   :type :documentation
1077   :type-spec (or string null)
1078   :default nil)
1079
1080 (define-info-type
1081   :class :function
1082   :type :definition
1083   :type-spec t
1084   :default nil)
1085 \f
1086 ;;;; definitions for other miscellaneous information
1087
1088 (define-info-class :variable)
1089
1090 ;;; The kind of variable-like thing described.
1091 (define-info-type
1092   :class :variable
1093   :type :kind
1094   :type-spec (member :special :constant :global :alien)
1095   :default (if (or (eq (symbol-package name) *keyword-package*)
1096                    (member name '(t nil)))
1097              :constant
1098              :global))
1099
1100 ;;; The declared type for this variable.
1101 (define-info-type
1102   :class :variable
1103   :type :type
1104   :type-spec ctype
1105   :default *universal-type*)
1106
1107 ;;; Where this type and kind information came from.
1108 (define-info-type
1109   :class :variable
1110   :type :where-from
1111   :type-spec (member :declared :assumed :defined)
1112   :default :assumed)
1113
1114 ;;; The lisp object which is the value of this constant, if known.
1115 (define-info-type
1116   :class :variable
1117   :type :constant-value
1118   :type-spec t
1119   :default (if (boundp name)
1120              (values (symbol-value name) t)
1121              (values nil nil)))
1122
1123 (define-info-type
1124   :class :variable
1125   :type :alien-info
1126   :type-spec (or heap-alien-info null)
1127   :default nil)
1128
1129 (define-info-type
1130   :class :variable
1131   :type :documentation
1132   :type-spec (or string null)
1133   :default nil)
1134
1135 (define-info-class :type)
1136
1137 ;;; The kind of type described. We return :INSTANCE for standard types that
1138 ;;; are implemented as structures.
1139 (define-info-type
1140   :class :type
1141   :type :kind
1142   :type-spec (member :primitive :defined :instance nil)
1143   :default nil)
1144
1145 ;;; Expander function for a defined type.
1146 (define-info-type
1147   :class :type
1148   :type :expander
1149   :type-spec (or function null)
1150   :default nil)
1151
1152 (define-info-type
1153   :class :type
1154   :type :documentation
1155   :type-spec (or string null))
1156
1157 ;;; function that parses type specifiers into CTYPE structures
1158 (define-info-type
1159   :class :type
1160   :type :translator
1161   :type-spec (or function null)
1162   :default nil)
1163
1164 ;;; If true, then the type coresponding to this name. Note that if
1165 ;;; this is a built-in class with a translation, then this is the
1166 ;;; translation, not the class object. This info type keeps track of
1167 ;;; various atomic types (NIL etc.) and also serves as a cache to
1168 ;;; ensure that common standard types (atomic and otherwise) are only
1169 ;;; consed once.
1170 (define-info-type
1171   :class :type
1172   :type :builtin
1173   :type-spec (or ctype null)
1174   :default nil)
1175
1176 ;;; If this is a class name, then the value is a cons (NAME . CLASS),
1177 ;;; where CLASS may be null if the class hasn't been defined yet. Note
1178 ;;; that for built-in classes, the kind may be :PRIMITIVE and not
1179 ;;; :INSTANCE. The the name is in the cons so that we can signal a
1180 ;;; meaningful error if we only have the cons.
1181 (define-info-type
1182   :class :type
1183   :type :class
1184   :type-spec (or sb!kernel::class-cell null)
1185   :default nil)
1186
1187 ;;; layout for this type being used by the compiler
1188 (define-info-type
1189   :class :type
1190   :type :compiler-layout
1191   :type-spec (or layout null)
1192   :default (let ((class (sb!xc:find-class name nil)))
1193              (when class (class-layout class))))
1194
1195 (define-info-class :typed-structure)
1196 (define-info-type
1197   :class :typed-structure
1198   :type :info
1199   :type-spec t
1200   :default nil)
1201
1202 (define-info-class :declaration)
1203 (define-info-type
1204   :class :declaration
1205   :type :recognized
1206   :type-spec boolean)
1207
1208 (define-info-class :alien-type)
1209 (define-info-type
1210   :class :alien-type
1211   :type :kind
1212   :type-spec (member :primitive :defined :unknown)
1213   :default :unknown)
1214 (define-info-type
1215   :class :alien-type
1216   :type :translator
1217   :type-spec (or function null)
1218   :default nil)
1219 (define-info-type
1220   :class :alien-type
1221   :type :definition
1222   :type-spec (or alien-type null)
1223   :default nil)
1224 (define-info-type
1225   :class :alien-type
1226   :type :struct
1227   :type-spec (or alien-type null)
1228   :default nil)
1229 (define-info-type
1230   :class :alien-type
1231   :type :union
1232   :type-spec (or alien-type null)
1233   :default nil)
1234 (define-info-type
1235   :class :alien-type
1236   :type :enum
1237   :type-spec (or alien-type null)
1238   :default nil)
1239
1240 (define-info-class :setf)
1241
1242 (define-info-type
1243   :class :setf
1244   :type :inverse
1245   :type-spec (or symbol null)
1246   :default nil)
1247
1248 (define-info-type
1249   :class :setf
1250   :type :documentation
1251   :type-spec (or string null)
1252   :default nil)
1253
1254 (define-info-type
1255   :class :setf
1256   :type :expander
1257   :type-spec (or function null)
1258   :default nil)
1259
1260 ;;; This is used for storing miscellaneous documentation types. The
1261 ;;; stuff is an alist translating documentation kinds to values.
1262 (define-info-class :random-documentation)
1263 (define-info-type
1264   :class :random-documentation
1265   :type :stuff
1266   :type-spec list
1267   :default ())
1268
1269 #!-sb-fluid (declaim (freeze-type info-env))
1270 \f
1271 ;;; Now that we have finished initializing *INFO-CLASSES* and
1272 ;;; *INFO-TYPES* (at compile time), generate code to set them at cold
1273 ;;; load time to the same state they have currently.
1274 (!cold-init-forms
1275   (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
1276   (setf *info-classes*
1277         (make-hash-table :size #.(hash-table-size *info-classes*)))
1278   (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
1279   (dolist (class-info-name '#.(let ((result nil))
1280                                 (maphash (lambda (key value)
1281                                            (declare (ignore value))
1282                                            (push key result))
1283                                          *info-classes*)
1284                                 result))
1285     (let ((class-info (make-class-info class-info-name)))
1286       (setf (gethash class-info-name *info-classes*)
1287             class-info)))
1288   (/show0 "done with *INFO-CLASSES* initialization")
1289   (/show0 "beginning *INFO-TYPES* initialization")
1290   (setf *info-types*
1291         (map 'vector
1292              (lambda (x)
1293                (when x
1294                  (let* ((class-info (class-info-or-lose (second x)))
1295                         (type-info (make-type-info :name (first x)
1296                                                    :class class-info
1297                                                    :number (third x)
1298                                                    :type (fourth x))))
1299                    (push type-info (class-info-types class-info))
1300                    type-info)))
1301              '#.(map 'list
1302                      (lambda (info-type)
1303                        (when info-type
1304                          (list (type-info-name info-type)
1305                                (class-info-name (type-info-class info-type))
1306                                (type-info-number info-type)
1307                                (type-info-type info-type))))
1308                      *info-types*)))
1309   (/show0 "done with *INFO-TYPES* initialization"))
1310
1311 ;;; At cold load time, after the INFO-TYPE objects have been created,
1312 ;;; we can set their DEFAULT and TYPE slots.
1313 (macrolet ((frob ()
1314              `(!cold-init-forms
1315                 ,@(reverse *reversed-type-info-init-forms*))))
1316   (frob))
1317 \f
1318 ;;;; a hack for detecting
1319 ;;;;   (DEFUN FOO (X Y)
1320 ;;;;     ..
1321 ;;;;     (SETF (BAR A FFH) 12) ; compiles to a call to #'(SETF BAR)
1322 ;;;;     ..)
1323 ;;;;   (DEFSETF BAR SET-BAR) ; can't influence previous compilation
1324 ;;;;
1325 ;;;; KLUDGE: Arguably it should be another class/type combination in
1326 ;;;; the globaldb. However, IMHO the whole globaldb/fdefinition
1327 ;;;; treatment of SETF functions is a mess which ought to be
1328 ;;;; rewritten, and I'm not inclined to mess with it short of that. So
1329 ;;;; I just put this bag on the side of it instead..
1330
1331 ;;; true for symbols FOO which have been assumed to have '(SETF FOO)
1332 ;;; bound to a function
1333 (defvar *setf-assumed-fboundp*)
1334 (!cold-init-forms (setf *setf-assumed-fboundp* (make-hash-table)))
1335 \f
1336 (!defun-from-collected-cold-init-forms !globaldb-cold-init)