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