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