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