src/compiler/globaldb.lisp

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