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