src/compiler/globaldb.lisp

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