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