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