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