src/compiler/globaldb.lisp

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