src/compiler/globaldb.lisp

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