0.8.11.13:

[sbcl.git] / src / compiler / globaldb.lisp

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index f99f6e6..c73acaa 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -32,11 +32,7 @@
 (declaim (special *universal-type*))
 
 ;;; This is sorta semantically equivalent to SXHASH, but optimized for
 (declaim (special *universal-type*))
 
 ;;; This is sorta semantically equivalent to SXHASH, but optimized for

-;;; legal function names. Note: semantically equivalent does *not*
-;;; mean that it always returns the same value as SXHASH, just that it
-;;; satisfies the formal definition of SXHASH. The ``sorta'' is
-;;; because SYMBOL-HASH will not necessarily return the same value in
-;;; different lisp images.
+;;; legal function names.

 ;;;
 ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
 ;;; SXHASH, because
 ;;;
 ;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
 ;;; SXHASH, because

@@ -58,17 +54,17 @@
 ;;; aren't used too early in cold boot for SXHASH to run).
 #!-sb-fluid (declaim (inline globaldb-sxhashoid))
 (defun globaldb-sxhashoid (x)
 ;;; aren't used too early in cold boot for SXHASH to run).
 #!-sb-fluid (declaim (inline globaldb-sxhashoid))
 (defun globaldb-sxhashoid (x)

-  (cond #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
-       ((symbolp x)
-        (symbol-hash x))
-       #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
+  (cond        ((symbolp x) (sxhash x))

        ((and (listp x)
              (eq (first x) 'setf)
              (let ((rest (rest x)))
                (and (symbolp (car rest))
                     (null (cdr rest)))))
        ((and (listp x)
              (eq (first x) 'setf)
              (let ((rest (rest x)))
                (and (symbolp (car rest))
                     (null (cdr rest)))))

-        (logxor (symbol-hash (second x))
-                110680597))
+        ;; We need to declare the type of the value we're feeding to
+        ;; SXHASH so that the DEFTRANSFORM on symbols kicks in.
+        (let ((symbol (second x)))
+          (declare (symbol symbol))
+          (logxor (sxhash symbol) 110680597)))

        (t (sxhash x))))
 
 ;;; Given any non-negative integer, return a prime number >= to it.
        (t (sxhash x))))
 
 ;;; Given any non-negative integer, return a prime number >= to it.

@@ -84,8 +80,7 @@
 (defun primify (x)
   (declare (type unsigned-byte x))
   (do ((n (logior x 1) (+ n 2)))
 (defun primify (x)
   (declare (type unsigned-byte x))
   (do ((n (logior x 1) (+ n 2)))

-      ((sb!sys:positive-primep n)
-       n)))
+      ((positive-primep n) n)))

 \f
 ;;;; info classes, info types, and type numbers, part I: what's needed
 ;;;; not only at compile time but also at run time
 \f
 ;;;; info classes, info types, and type numbers, part I: what's needed
 ;;;; not only at compile time but also at run time

@@ -100,7 +95,8 @@
 
 ;;; At run time, we represent the type of info that we want by a small
 ;;; non-negative integer.
 
 ;;; At run time, we represent the type of info that we want by a small
 ;;; non-negative integer.

-(defconstant type-number-bits 6)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (def!constant type-number-bits 6))

 (deftype type-number () `(unsigned-byte ,type-number-bits))
 
 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're
 (deftype type-number () `(unsigned-byte ,type-number-bits))
 
 ;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're

@@ -125,17 +121,25 @@
            (:copier nil))
   ;; name of this class
   (name nil :type keyword :read-only t)
            (:copier nil))
   ;; name of this class
   (name nil :type keyword :read-only t)

-  ;; List of Type-Info structures for each type in this class.
+  ;; list of Type-Info structures for each type in this class

   (types () :type list))
 
 ;;; a map from type numbers to TYPE-INFO objects. There is one type
 ;;; number for each defined CLASS/TYPE pair.
 ;;;
   (types () :type list))
 
 ;;; a map from type numbers to TYPE-INFO objects. There is one type
 ;;; number for each defined CLASS/TYPE pair.
 ;;;

-;;; We build its value at compile time (with calls to
+;;; We build its value at build-the-cross-compiler time (with calls to

 ;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
 ;;; value, and arrange for that code to be called in cold load.
 ;;; DEFINE-INFO-TYPE), then generate code to recreate the compile time
 ;;; value, and arrange for that code to be called in cold load.

+;;; KLUDGE: We don't try to reset its value when cross-compiling the
+;;; compiler, since that creates too many bootstrapping problems,
+;;; instead just reusing the built-in-the-cross-compiler version,
+;;; which is theoretically a little bit ugly but pretty safe in
+;;; practice because the cross-compiler is as close to the target
+;;; compiler as we can make it, i.e. identical in most ways, including
+;;; this one. -- WHN 2001-08-19

 (defvar *info-types*)
 (declaim (type simple-vector *info-types*))
 (defvar *info-types*)
 (declaim (type simple-vector *info-types*))

+#-sb-xc ; as per KLUDGE note above

 (eval-when (:compile-toplevel :execute)
   (setf *info-types*
        (make-array (ash 1 type-number-bits) :initial-element nil)))
 (eval-when (:compile-toplevel :execute)
   (setf *info-types*
        (make-array (ash 1 type-number-bits) :initial-element nil)))

@@ -145,17 +149,17 @@
            (:print-object (lambda (x s)
                             (print-unreadable-object (x s)
                               (format s
            (:print-object (lambda (x s)
                             (print-unreadable-object (x s)
                               (format s

-                                      "~S ~S, Number = ~D"
+                                      "~S ~S, Number = ~W"

                                       (class-info-name (type-info-class x))
                                       (type-info-name x)
                                       (type-info-number x)))))
            (:copier nil))
   ;; the name of this type
                                       (class-info-name (type-info-class x))
                                       (type-info-name x)
                                       (type-info-number x)))))
            (:copier nil))
   ;; the name of this type

-  (name (required-argument) :type keyword)
+  (name (missing-arg) :type keyword)

   ;; this type's class
   ;; this type's class

-  (class (required-argument) :type class-info)
+  (class (missing-arg) :type class-info)

   ;; a number that uniquely identifies this type (and implicitly its class)
   ;; a number that uniquely identifies this type (and implicitly its class)

-  (number (required-argument) :type type-number)
+  (number (missing-arg) :type type-number)

   ;; a type specifier which info of this type must satisfy
   (type nil :type t)
   ;; a function called when there is no information of this type
   ;; a type specifier which info of this type must satisfy
   (type nil :type t)
   ;; a function called when there is no information of this type

@@ -166,8 +170,12 @@
 ;;; We build the value for this at compile time (with calls to
 ;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
 ;;; value, and arrange for that code to be called in cold load.
 ;;; We build the value for this at compile time (with calls to
 ;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
 ;;; value, and arrange for that code to be called in cold load.

+;;; KLUDGE: Just as for *INFO-TYPES*, we don't try to rebuild this
+;;; when cross-compiling, but instead just reuse the cross-compiler's
+;;; version for the target compiler. -- WHN 2001-08-19

 (defvar *info-classes*)
 (declaim (hash-table *info-classes*))
 (defvar *info-classes*)
 (declaim (hash-table *info-classes*))

+#-sb-xc ; as per KLUDGE note above

 (eval-when (:compile-toplevel :execute)
   (setf *info-classes* (make-hash-table)))
 
 (eval-when (:compile-toplevel :execute)
   (setf *info-classes* (make-hash-table)))
 

@@ -251,26 +259,24 @@
 ;;; order in which the TYPE-INFO-creation forms are generated doesn't
 ;;; match the relative order in which the forms need to be executed at
 ;;; cold load time.
 ;;; order in which the TYPE-INFO-creation forms are generated doesn't
 ;;; match the relative order in which the forms need to be executed at
 ;;; cold load time.

-(defparameter *reversed-type-info-init-forms* nil)
-
+(defparameter *!reversed-type-info-init-forms* nil)
+
+;;; Define a new type of global information for CLASS. TYPE is the
+;;; name of the type, DEFAULT is the value for that type when it
+;;; hasn't been set, and TYPE-SPEC is a type specifier which values of
+;;; the type must satisfy. The default expression is evaluated each
+;;; time the information is needed, with NAME bound to the name for
+;;; which the information is being looked up. 
+;;;

 ;;; The main thing we do is determine the type's number. We need to do
 ;;; this at macroexpansion time, since both the COMPILE and LOAD time
 ;;; calls to %DEFINE-INFO-TYPE must use the same type number.
 (#+sb-xc-host defmacro
  #-sb-xc-host sb!xc:defmacro
 ;;; The main thing we do is determine the type's number. We need to do
 ;;; this at macroexpansion time, since both the COMPILE and LOAD time
 ;;; calls to %DEFINE-INFO-TYPE must use the same type number.
 (#+sb-xc-host defmacro
  #-sb-xc-host sb!xc:defmacro

-    define-info-type (&key (class (required-argument))
-                          (type (required-argument))
-                          (type-spec (required-argument))
+    define-info-type (&key (class (missing-arg))
+                          (type (missing-arg))
+                          (type-spec (missing-arg))

                           default)
                           default)

-  #!+sb-doc
-  "Define-Info-Type Class Type default Type-Spec
-  Define a new type of global information for Class. Type is the name
-  of the type, Default is the value for that type when it hasn't been set, and
-  Type-Spec is a type-specifier which values of the type must satisfy. The
-  default expression is evaluated each time the information is needed, with
-  Name bound to the name for which the information is being looked up. If the
-  default evaluates to something with the second value true, then the second
-  value of Info will also be true."

   (declare (type keyword class type))
   `(progn
      (eval-when (:compile-toplevel :execute)
   (declare (type keyword class type))
   `(progn
      (eval-when (:compile-toplevel :execute)

@@ -310,7 +316,7 @@
                         (declare (ignorable name))
                         ,',default))
                (setf (type-info-type type-info) ',',type-spec))
                         (declare (ignorable name))
                         ,',default))
                (setf (type-info-type type-info) ',',type-spec))

-            *reversed-type-info-init-forms*))
+            *!reversed-type-info-init-forms*))

      ',type))
 
 ) ; EVAL-WHEN
      ',type))
 
 ) ; EVAL-WHEN

@@ -326,7 +332,7 @@
                     (:copier nil))
   ;; some string describing what is in this environment, for
   ;; printing/debugging purposes only
                     (:copier nil))
   ;; some string describing what is in this environment, for
   ;; printing/debugging purposes only

-  (name (required-argument) :type string))
+  (name (missing-arg) :type string))

 (def!method print-object ((x info-env) stream)
   (print-unreadable-object (x stream :type t)
     (prin1 (info-env-name x) stream)))
 (def!method print-object ((x info-env) stream)
   (print-unreadable-object (x stream :type t)
     (prin1 (info-env-name x) stream)))

@@ -350,7 +356,7 @@
             ,(do-compact-info name class type type-number value
                               n-env body)))))
 
             ,(do-compact-info name class type type-number value
                               n-env body)))))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 ;;; Return code to iterate over a compact info environment.
 (defun do-compact-info (name-var class-var type-var type-number-var value-var
 
 ;;; Return code to iterate over a compact info environment.
 (defun do-compact-info (name-var class-var type-var type-number-var value-var

@@ -470,7 +476,7 @@
 ;;;; compact info environments
 
 ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
 ;;;; compact info environments
 
 ;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.

-(defconstant compact-info-env-entries-bits 16)
+(def!constant compact-info-env-entries-bits 16)

 (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
 
 ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO
 (deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
 
 ;;; the type of the values in COMPACT-INFO-ENTRIES-INFO

@@ -491,27 +497,26 @@
   (cache-index nil :type (or compact-info-entries-index null))
   ;; hashtable of the names in this environment. If a bucket is
   ;; unused, it is 0.
   (cache-index nil :type (or compact-info-entries-index null))
   ;; hashtable of the names in this environment. If a bucket is
   ;; unused, it is 0.

-  (table (required-argument) :type simple-vector)
+  (table (missing-arg) :type simple-vector)

   ;; an indirection vector parallel to TABLE, translating indices in
   ;; TABLE to the start of the ENTRIES for that name. Unused entries
   ;; are undefined.
   ;; an indirection vector parallel to TABLE, translating indices in
   ;; TABLE to the start of the ENTRIES for that name. Unused entries
   ;; are undefined.

-  (index (required-argument)
-        :type (simple-array compact-info-entries-index (*)))
+  (index (missing-arg) :type (simple-array compact-info-entries-index (*)))

   ;; a vector contining in contiguous ranges the values of for all the
   ;; types of info for each name.
   ;; a vector contining in contiguous ranges the values of for all the
   ;; types of info for each name.

-  (entries (required-argument) :type simple-vector)
-  ;; Vector parallel to ENTRIES, indicating the type number for the value
-  ;; stored in that location and whether this location is the last type of info
-  ;; stored for this name. The type number is in the low TYPE-NUMBER-BITS
-  ;; bits, and the next bit is set if this is the last entry.
-  (entries-info (required-argument)
-               :type (simple-array compact-info-entry (*))))
-
-(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
-(defconstant compact-info-entry-last (ash 1 type-number-bits))
-
-;;; Return the value of the type corresponding to Number for the currently
-;;; cached name in Env.
+  (entries (missing-arg) :type simple-vector)
+  ;; a vector parallel to ENTRIES, indicating the type number for the
+  ;; value stored in that location and whether this location is the
+  ;; last type of info stored for this name. The type number is in the
+  ;; low TYPE-NUMBER-BITS bits, and the next bit is set if this is the
+  ;; last entry.
+  (entries-info (missing-arg) :type (simple-array compact-info-entry (*))))
+
+(def!constant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
+(def!constant compact-info-entry-last (ash 1 type-number-bits))
+
+;;; Return the value of the type corresponding to NUMBER for the
+;;; currently cached name in ENV.

 #!-sb-fluid (declaim (inline compact-info-cache-hit))
 (defun compact-info-cache-hit (env number)
   (declare (type compact-info-env env) (type type-number number))
 #!-sb-fluid (declaim (inline compact-info-cache-hit))
 (defun compact-info-cache-hit (env number)
   (declare (type compact-info-env env) (type type-number number))

@@ -529,10 +534,23 @@
              (return (values nil nil)))))
        (values nil nil))))
 
              (return (values nil nil)))))
        (values nil nil))))
 

-;;; Encache Name in the compact environment Env. Hash is the
-;;; GLOBALDB-SXHASHOID of Name.
+;;; Encache NAME in the compact environment ENV. HASH is the
+;;; GLOBALDB-SXHASHOID of NAME.

 (defun compact-info-lookup (env name hash)
 (defun compact-info-lookup (env name hash)

-  (declare (type compact-info-env env) (type index hash))
+  (declare (type compact-info-env env)
+          ;; FIXME: this used to read (TYPE INDEX HASH), but that was
+          ;; wrong, because HASH was a positive fixnum, not a (MOD
+          ;; MOST-POSITIVE-FIXNUM).
+          ;;
+          ;; However, this, its replacement, is also wrong.  In the
+          ;; cross-compiler, GLOBALDB-SXHASHOID is essentially
+          ;; SXHASH.  But our host compiler could have any value at
+          ;; all as its MOST-POSITIVE-FIXNUM, and so could in
+          ;; principle return a value exceeding our target positive
+          ;; fixnum range.
+          ;;
+          ;; My brain hurts.  -- CSR, 2003-08-28
+          (type (integer 0 #.sb!xc:most-positive-fixnum) hash))

   (let* ((table (compact-info-env-table env))
         (len (length table))
         (len-2 (- len 2))
   (let* ((table (compact-info-env-table env))
         (len (length table))
         (len-2 (- len 2))

@@ -542,7 +560,7 @@
                 `(do ((probe (rem hash len)
                              (let ((new (+ probe hash2)))
                                (declare (type index new))
                 `(do ((probe (rem hash len)
                              (let ((new (+ probe hash2)))
                                (declare (type index new))

-                               ;; same as (mod new len), but faster.
+                               ;; same as (MOD NEW LEN), but faster.

                                (if (>= new len)
                                    (the index (- new len))
                                    new))))
                                (if (>= new len)
                                    (the index (- new len))
                                    new))))

@@ -563,7 +581,7 @@
 
 ;;; the exact density (modulo rounding) of the hashtable in a compact
 ;;; info environment in names/bucket
 
 ;;; the exact density (modulo rounding) of the hashtable in a compact
 ;;; info environment in names/bucket

-(defconstant compact-info-environment-density 65)
+(def!constant compact-info-environment-density 65)

 
 ;;; Return a new compact info environment that holds the same
 ;;; information as ENV.
 
 ;;; Return a new compact info environment that holds the same
 ;;; information as ENV.

@@ -637,7 +655,7 @@
                    (setf (svref table probe) name)
                    (setf (aref index probe) entries-idx)
                    (return))
                    (setf (svref table probe) name)
                    (setf (aref index probe) entries-idx)
                    (return))

-                 (assert (not (equal entry name))))))
+                 (aver (not (equal entry name))))))

 
            (unless (zerop entries-idx)
              (setf (aref entries-info (1- entries-idx))
 
            (unless (zerop entries-idx)
              (setf (aref entries-info (1- entries-idx))

@@ -677,7 +695,7 @@
   (cache-types nil :type list)
   ;; vector of alists of alists of the form:
   ;;    ((Name . ((Type-Number . Value) ...) ...)
   (cache-types nil :type list)
   ;; vector of alists of alists of the form:
   ;;    ((Name . ((Type-Number . Value) ...) ...)

-  (table (required-argument) :type simple-vector)
+  (table (missing-arg) :type simple-vector)

   ;; the number of distinct names currently in this table. Each name
   ;; may have multiple entries, since there can be many types of info.
   (count 0 :type index)
   ;; the number of distinct names currently in this table. Each name
   ;; may have multiple entries, since there can be many types of info.
   (count 0 :type index)

@@ -694,7 +712,9 @@
 
 ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
 (defun volatile-info-lookup (env name hash)
 
 ;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
 (defun volatile-info-lookup (env name hash)

-  (declare (type volatile-info-env env) (type index hash))
+  (declare (type volatile-info-env env)
+          ;; FIXME: see comment in COMPACT-INFO-LOOKUP
+          (type (integer 0 #.sb!xc:most-positive-fixnum) hash))

   (let ((table (volatile-info-env-table env)))
     (macrolet ((lookup (test)
                 `(dolist (entry (svref table (mod hash (length table))) ())
   (let ((table (volatile-info-env-table env)))
     (macrolet ((lookup (test)
                 `(dolist (entry (svref table (mod hash (length table))) ())

@@ -705,11 +725,10 @@
                (lookup eq)
                (lookup equal)))
       (setf (volatile-info-env-cache-name env) name)))
                (lookup eq)
                (lookup equal)))
       (setf (volatile-info-env-cache-name env) name)))

-

   (values))
 
   (values))
 

-;;; Given a volatile environment Env, bind Table-Var the environment's table
-;;; and Index-Var to the index of Name's bucket in the table. We also flush
+;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table
+;;; and INDEX-VAR to the index of NAME's bucket in the table. We also flush

 ;;; the cache so that things will be consistent if body modifies something.
 (eval-when (:compile-toplevel :execute)
   (#+sb-xc-host cl:defmacro
 ;;; the cache so that things will be consistent if body modifies something.
 (eval-when (:compile-toplevel :execute)
   (#+sb-xc-host cl:defmacro

@@ -791,30 +810,33 @@
 ;;; foldable.)
 
 ;;; INFO is the standard way to access the database. It's settable.
 ;;; foldable.)
 
 ;;; INFO is the standard way to access the database. It's settable.

+;;;
+;;; Return the information of the specified TYPE and CLASS for NAME.
+;;; The second value returned is true if there is any such information
+;;; recorded. If there is no information, the first value returned is
+;;; the default and the second value returned is NIL.

 (defun info (class type name &optional (env-list nil env-list-p))
 (defun info (class type name &optional (env-list nil env-list-p))

-  #!+sb-doc
-  "Return the information of the specified TYPE and CLASS for NAME.
-   The second value returned is true if there is any such information
-   recorded. If there is no information, the first value returned is
-   the default and the second value returned is NIL."
-  ;; FIXME: At some point check systematically to make sure that the system
-  ;; doesn't do any full calls to INFO or (SETF INFO), or at least none in any
-  ;; inner loops.
+  ;; FIXME: At some point check systematically to make sure that the
+  ;; system doesn't do any full calls to INFO or (SETF INFO), or at
+  ;; least none in any inner loops.

   (let ((info (type-info-or-lose class type)))
     (if env-list-p
   (let ((info (type-info-or-lose class type)))
     (if env-list-p

-      (get-info-value name (type-info-number info) env-list)
-      (get-info-value name (type-info-number info)))))
+       (get-info-value name (type-info-number info) env-list)
+       (get-info-value name (type-info-number info)))))

 #!-sb-fluid
 (define-compiler-macro info
   (&whole whole class type name &optional (env-list nil env-list-p))
 #!-sb-fluid
 (define-compiler-macro info
   (&whole whole class type name &optional (env-list nil env-list-p))

-  ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
-  ;; can resolve it much more efficiently than the general case.
+  ;; Constant CLASS and TYPE is an overwhelmingly common special case,
+  ;; and we can implement it much more efficiently than the general case.

   (if (and (constantp class) (constantp type))
       (let ((info (type-info-or-lose class type)))
   (if (and (constantp class) (constantp type))
       (let ((info (type-info-or-lose class type)))

-       `(the ,(type-info-type info)
-          (get-info-value ,name
-                          ,(type-info-number info)
-                          ,@(when env-list-p `(,env-list)))))
+       (with-unique-names (value foundp)
+         `(multiple-value-bind (,value ,foundp)
+              (get-info-value ,name
+                              ,(type-info-number info)
+                              ,@(when env-list-p `(,env-list))) 
+            (declare (type ,(type-info-type info) ,value))
+            (values ,value ,foundp))))

       whole))
 (defun (setf info) (new-value
                    class
       whole))
 (defun (setf info) (new-value
                    class

@@ -824,13 +846,13 @@
   (let* ((info (type-info-or-lose class type))
         (tin (type-info-number info)))
     (if env-list-p
   (let* ((info (type-info-or-lose class type))
         (tin (type-info-number info)))
     (if env-list-p

-      (set-info-value name
-                     tin
-                     new-value
-                     (get-write-info-env env-list))
-      (set-info-value name
-                     tin
-                     new-value)))
+       (set-info-value name
+                       tin
+                       new-value
+                       (get-write-info-env env-list))
+       (set-info-value name
+                       tin
+                       new-value)))

   new-value)
 ;;; FIXME: We'd like to do this, but Python doesn't support
 ;;; compiler macros and it's hard to change it so that it does.
   new-value)
 ;;; FIXME: We'd like to do this, but Python doesn't support
 ;;; compiler macros and it's hard to change it so that it does.

@@ -869,7 +891,7 @@
 ;;;
 ;;; FIXME: actually seems to be measured in percent, should be
 ;;; converted to be measured in names/bucket
 ;;;
 ;;; FIXME: actually seems to be measured in percent, should be
 ;;; converted to be measured in names/bucket

-(defconstant volatile-info-environment-density 50)
+(def!constant volatile-info-environment-density 50)

 
 ;;; Make a new volatile environment of the specified size.
 (defun make-info-environment (&key (size 42) (name "Unknown"))
 
 ;;; Make a new volatile environment of the specified size.
 (defun make-info-environment (&key (size 42) (name "Unknown"))

@@ -880,11 +902,10 @@
                            :table (make-array table-size :initial-element nil)
                            :threshold size)))
 
                            :table (make-array table-size :initial-element nil)
                            :threshold size)))
 

+;;; Clear the information of the specified TYPE and CLASS for NAME in
+;;; the current environment, allowing any inherited info to become
+;;; visible. We return true if there was any info.

 (defun clear-info (class type name)
 (defun clear-info (class type name)

-  #!+sb-doc
-  "Clear the information of the specified Type and Class for Name in the
-  current environment, allowing any inherited info to become visible. We
-  return true if there was any info."

   (let ((info (type-info-or-lose class type)))
     (clear-info-value name (type-info-number info))))
 #!-sb-fluid
   (let ((info (type-info-or-lose class type)))
     (clear-info-value name (type-info-number info))))
 #!-sb-fluid

@@ -925,14 +946,21 @@
 ;;; Check whether the name and type is in our cache, if so return it.
 ;;; Otherwise, search for the value and encache it.
 ;;;
 ;;; Check whether the name and type is in our cache, if so return it.
 ;;; Otherwise, search for the value and encache it.
 ;;;

-;;; Return the value from the first environment which has it defined, or
-;;; return the default if none does. We have a cache for the last name looked
-;;; up in each environment. We don't compute the hash until the first time the
-;;; cache misses. When the cache does miss, we invalidate it before calling the
-;;; lookup routine to eliminate the possiblity of the cache being partially
-;;; updated if the lookup is interrupted.
+;;; Return the value from the first environment which has it defined,
+;;; or return the default if none does. We have a cache for the last
+;;; name looked up in each environment. We don't compute the hash
+;;; until the first time the cache misses. When the cache does miss,
+;;; we invalidate it before calling the lookup routine to eliminate
+;;; the possibility of the cache being partially updated if the lookup
+;;; is interrupted.

 (defun get-info-value (name0 type &optional (env-list nil env-list-p))
   (declare (type type-number type))
 (defun get-info-value (name0 type &optional (env-list nil env-list-p))
   (declare (type type-number type))

+  ;; sanity check: If we have screwed up initialization somehow, then
+  ;; *INFO-TYPES* could still be uninitialized at the time we try to
+  ;; get an info value, and then we'd be out of luck. (This happened,
+  ;; and was confusing to debug, when rewriting EVAL-WHEN in
+  ;; sbcl-0.pre7.x.)
+  (aver (aref *info-types* type))

   (let ((name (uncross name0)))
     (flet ((lookup-ignoring-global-cache (env-list)
             (let ((hash nil))
   (let ((name (uncross name0)))
     (flet ((lookup-ignoring-global-cache (env-list)
             (let ((hash nil))

@@ -952,11 +980,15 @@
                                 (multiple-value-bind (value winp)
                                     (,cache env type)
                                   (when winp (return (values value t)))))))
                                 (multiple-value-bind (value winp)
                                     (,cache env type)
                                   (when winp (return (values value t)))))))

-                  (if (typep env 'volatile-info-env)
-                  (frob volatile-info-lookup volatile-info-cache-hit
-                        volatile-info-env-cache-name)
-                  (frob compact-info-lookup compact-info-cache-hit
-                        compact-info-env-cache-name)))))))
+                  (etypecase env
+                    (volatile-info-env (frob
+                                        volatile-info-lookup
+                                        volatile-info-cache-hit
+                                        volatile-info-env-cache-name))
+                    (compact-info-env (frob
+                                       compact-info-lookup
+                                       compact-info-cache-hit
+                                       compact-info-env-cache-name))))))))

       (cond (env-list-p
             (lookup-ignoring-global-cache env-list))
            (t
       (cond (env-list-p
             (lookup-ignoring-global-cache env-list))
            (t

@@ -1000,7 +1032,7 @@
   :default
   #+sb-xc-host (specifier-type 'function)
   #-sb-xc-host (if (fboundp name)
   :default
   #+sb-xc-host (specifier-type 'function)
   #-sb-xc-host (if (fboundp name)

-                  (extract-function-type (fdefinition name))
+                  (extract-fun-type (fdefinition name))

                   (specifier-type 'function)))
 
 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
                   (specifier-type 'function)))
 
 ;;; the ASSUMED-TYPE for this function, if we have to infer the type

@@ -1009,21 +1041,19 @@
   :class :function
   :type :assumed-type
   ;; FIXME: The type-spec really should be
   :class :function
   :type :assumed-type
   ;; FIXME: The type-spec really should be

-  ;;   (or approximate-function-type null)).
+  ;;   (or approximate-fun-type null)).

   ;; It was changed to T as a hopefully-temporary hack while getting
   ;; cold init problems untangled.
   ;; It was changed to T as a hopefully-temporary hack while getting
   ;; cold init problems untangled.

-  :type-spec t) 
+  :type-spec t)

 
 ;;; where this information came from:
 
 ;;; where this information came from:

-;;;  :DECLARED = from a declaration.
-;;;  :ASSUMED  = from uses of the object.
-;;;  :DEFINED  = from examination of the definition.
-;;; FIXME: The :DEFINED assumption that the definition won't change
-;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way
-;;; which violates its "type declarations are assertions" principle,
-;;; and SBCL has inherited that behavior. It would be really good to
-;;; fix the compiler so that it tests the return types of functions..
-;;; -- WHN ca. 19990801
+;;;    :ASSUMED  = from uses of the object
+;;;    :DEFINED  = from examination of the definition
+;;;    :DECLARED = from a declaration
+;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
+;;; and :DECLARED is useful for ANSIly specializing code which
+;;; implements the function, or which uses the function's return values.

 (define-info-type
   :class :function
   :type :where-from
 (define-info-type
   :class :function
   :type :where-from

@@ -1035,11 +1065,31 @@
   #+sb-xc-host :assumed
   #-sb-xc-host (if (fboundp name) :defined :assumed))
 
   #+sb-xc-host :assumed
   #-sb-xc-host (if (fboundp name) :defined :assumed))
 

-;;; lambda used for inline expansion of this function
+;;; something which can be decoded into the inline expansion of the
+;;; function, or NIL if there is none
+;;;
+;;; To inline a function, we want a lambda expression, e.g.
+;;; '(LAMBDA (X) (+ X 1)). That can be encoded here in one of two
+;;; ways.
+;;;   * The value in INFO can be the lambda expression itself, e.g. 
+;;;       (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'FOO)
+;;;             '(LAMBDA (X) (+ X 1)))
+;;;     This is the ordinary way, the natural way of representing e.g.
+;;;       (DECLAIM (INLINE FOO))
+;;;       (DEFUN FOO (X) (+ X 1))
+;;;   * The value in INFO can be a closure which returns the lambda
+;;;     expression, e.g.
+;;;       (SETF (INFO :FUNCTION :INLINE-EXPANSION-DESIGNATOR 'BAR-LEFT-CHILD)
+;;;             (LAMBDA ()
+;;;               '(LAMBDA (BAR) (BAR-REF BAR 3))))
+;;;     This twisty way of storing values is supported in order to
+;;;     allow structure slot accessors, and perhaps later other
+;;;     stereotyped functions, to be represented compactly.

 (define-info-type
   :class :function
 (define-info-type
   :class :function

-  :type :inline-expansion
-  :type-spec list)
+  :type :inline-expansion-designator
+  :type-spec (or list function)
+  :default nil)

 
 ;;; This specifies whether this function may be expanded inline. If
 ;;; null, we don't care.
 
 ;;; This specifies whether this function may be expanded inline. If
 ;;; null, we don't care.

@@ -1077,28 +1127,12 @@
   :type :ir1-convert
   :type-spec (or function null))
 
   :type :ir1-convert
   :type-spec (or function null))
 

-;;; a function which gets a chance to do stuff to the IR1 for any call
-;;; to this function.
-(define-info-type
-  :class :function
-  :type :ir1-transform
-  :type-spec (or function null))
-
-;;; If a function is a slot accessor or setter, then this is the class
-;;; that it accesses slots of.
-(define-info-type
-  :class :function
-  :type :accessor-for
-  :type-spec (or sb!xc:class null)
-  :default nil)
-
-;;; If a function is "known" to the compiler, then this is a
-;;; FUNCTION-INFO structure containing the info used to special-case
-;;; compilation.
+;;; If a function is "known" to the compiler, then this is a FUN-INFO
+;;; structure containing the info used to special-case compilation.

 (define-info-type
   :class :function
   :type :info
 (define-info-type
   :class :function
   :type :info

-  :type-spec (or function-info null)
+  :type-spec (or fun-info null)

   :default nil)
 
 (define-info-type
   :default nil)
 
 (define-info-type

@@ -1110,45 +1144,58 @@
 (define-info-type
   :class :function
   :type :definition
 (define-info-type
   :class :function
   :type :definition

-  :type-spec t
+  :type-spec (or fdefn null)

   :default nil)
 \f
 ;;;; definitions for other miscellaneous information
 
 (define-info-class :variable)
 
   :default nil)
 \f
 ;;;; definitions for other miscellaneous information
 
 (define-info-class :variable)
 

-;;; The kind of variable-like thing described.
+;;; the kind of variable-like thing described

 (define-info-type
   :class :variable
   :type :kind
 (define-info-type
   :class :variable
   :type :kind

-  :type-spec (member :special :constant :global :alien)
-  :default (if (or (eq (symbol-package name) *keyword-package*)
-                  (member name '(t nil)))
-            :constant
-            :global))
+  :type-spec (member :special :constant :macro :global :alien)
+  :default (if (symbol-self-evaluating-p name)
+              :constant
+              :global))

 
 

-;;; The declared type for this variable.
+;;; the declared type for this variable

 (define-info-type
   :class :variable
   :type :type
   :type-spec ctype
   :default *universal-type*)
 
 (define-info-type
   :class :variable
   :type :type
   :type-spec ctype
   :default *universal-type*)
 

-;;; Where this type and kind information came from.
+;;; where this type and kind information came from

 (define-info-type
   :class :variable
   :type :where-from
   :type-spec (member :declared :assumed :defined)
   :default :assumed)
 
 (define-info-type
   :class :variable
   :type :where-from
   :type-spec (member :declared :assumed :defined)
   :default :assumed)
 

-;;; The lisp object which is the value of this constant, if known.
+;;; the Lisp object which is the value of this constant, if known

 (define-info-type
   :class :variable
   :type :constant-value
   :type-spec t
 (define-info-type
   :class :variable
   :type :constant-value
   :type-spec t

-  :default (if (boundp name)
-            (values (symbol-value name) t)
-            (values nil nil)))
+  ;; CMU CL used to return two values for (INFO :VARIABLE :CONSTANT-VALUE ..).
+  ;; Now we don't: it was the last remaining multiple-value return from
+  ;; the INFO system, and bringing it down to one value lets us simplify
+  ;; things, especially simplifying the declaration of return types.
+  ;; Software which used to check the second value (for "is it defined
+  ;; as a constant?") should check (EQL (INFO :VARIABLE :KIND ..) :CONSTANT)
+  ;; instead.
+  :default (if (symbol-self-evaluating-p name)
+              name
+              (bug "constant lookup of nonconstant ~S" name)))
+
+;;; the macro-expansion for symbol-macros
+(define-info-type
+  :class :variable
+  :type :macro-expansion
+  :type-spec t
+  :default nil)

 
 (define-info-type
   :class :variable
 
 (define-info-type
   :class :variable

@@ -1164,15 +1211,18 @@
 
 (define-info-class :type)
 
 
 (define-info-class :type)
 

-;;; The kind of type described. We return :INSTANCE for standard types that
-;;; are implemented as structures.
+;;; the kind of type described. We return :INSTANCE for standard types
+;;; that are implemented as structures. For PCL classes, that have
+;;; only been compiled, but not loaded yet, we return
+;;; :FORTHCOMING-DEFCLASS-TYPE.

 (define-info-type
   :class :type
   :type :kind
 (define-info-type
   :class :type
   :type :kind

-  :type-spec (member :primitive :defined :instance nil)
+  :type-spec (member :primitive :defined :instance
+                    :forthcoming-defclass-type nil)

   :default nil)
 
   :default nil)
 

-;;; Expander function for a defined type.
+;;; the expander function for a defined type

 (define-info-type
   :class :type
   :type :expander
 (define-info-type
   :class :type
   :type :expander

@@ -1206,12 +1256,12 @@
 ;;; If this is a class name, then the value is a cons (NAME . CLASS),
 ;;; where CLASS may be null if the class hasn't been defined yet. Note
 ;;; that for built-in classes, the kind may be :PRIMITIVE and not
 ;;; If this is a class name, then the value is a cons (NAME . CLASS),
 ;;; where CLASS may be null if the class hasn't been defined yet. Note
 ;;; that for built-in classes, the kind may be :PRIMITIVE and not

-;;; :INSTANCE. The the name is in the cons so that we can signal a
+;;; :INSTANCE. The name is in the cons so that we can signal a

 ;;; meaningful error if we only have the cons.
 (define-info-type
   :class :type
 ;;; meaningful error if we only have the cons.
 (define-info-type
   :class :type

-  :type :class
-  :type-spec (or sb!kernel::class-cell null)
+  :type :classoid
+  :type-spec (or sb!kernel::classoid-cell null)

   :default nil)
 
 ;;; layout for this type being used by the compiler
   :default nil)
 
 ;;; layout for this type being used by the compiler

@@ -1219,8 +1269,8 @@
   :class :type
   :type :compiler-layout
   :type-spec (or layout null)
   :class :type
   :type :compiler-layout
   :type-spec (or layout null)

-  :default (let ((class (sb!xc:find-class name nil)))
-            (when class (class-layout class))))
+  :default (let ((class (find-classoid name nil)))
+            (when class (classoid-layout class))))

 
 (define-info-class :typed-structure)
 (define-info-type
 
 (define-info-class :typed-structure)
 (define-info-type

@@ -1345,7 +1395,7 @@
 ;;; we can set their DEFAULT and TYPE slots.
 (macrolet ((frob ()
             `(!cold-init-forms
 ;;; we can set their DEFAULT and TYPE slots.
 (macrolet ((frob ()
             `(!cold-init-forms

-               ,@(reverse *reversed-type-info-init-forms*))))
+               ,@(reverse *!reversed-type-info-init-forms*))))

   (frob))
 \f
 ;;;; a hack for detecting
   (frob))
 \f
 ;;;; a hack for detecting