0.8.19.30: less COMPILE-FILE verbosity

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

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index ad7d732..c73acaa 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -31,11 +31,8 @@
 ;;; FIXME: centralize
 (declaim (special *universal-type*))
 
 ;;; FIXME: centralize
 (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.
+;;; This is sorta semantically equivalent to SXHASH, but optimized for
+;;; 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

@@ -54,36 +51,36 @@
 ;;; to hold all manner of things, e.g. (INFO :TYPE :BUILTIN ..)
 ;;; which is called on values like (UNSIGNED-BYTE 29). Falling through
 ;;; to SXHASH lets us support all manner of things (as long as they
 ;;; to hold all manner of things, e.g. (INFO :TYPE :BUILTIN ..)
 ;;; which is called on values like (UNSIGNED-BYTE 29). Falling through
 ;;; to SXHASH lets us support all manner of things (as long as they

-;;; aren't used too early in cold boot).
+;;; aren't used too early in cold boot for SXHASH to run).

 #!-sb-fluid (declaim (inline globaldb-sxhashoid))
 (defun globaldb-sxhashoid (x)
 #!-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.
 ;;;

-;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in hash-table.lisp.
-;;; Perhaps the merged logic should be PRIMIFY-HASH-TABLE-SIZE, implemented as
-;;; a lookup table of primes after integral powers of two:
+;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in
+;;; hash-table.lisp. Perhaps the merged logic should be
+;;; PRIMIFY-HASH-TABLE-SIZE, implemented as a lookup table of primes
+;;; after integral powers of two:

 ;;;    #(17 37 67 131 ..)
 ;;;    #(17 37 67 131 ..)

-;;; (Or, if that's too coarse, after half-integral powers of two.) By thus
-;;; getting rid of any need for primality testing at runtime, we could
-;;; punt POSITIVE-PRIMEP, too.
+;;; (Or, if that's too coarse, after half-integral powers of two.) By
+;;; thus getting rid of any need for primality testing at runtime, we
+;;; could punt POSITIVE-PRIMEP, too.

 (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

@@ -98,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

@@ -119,20 +117,29 @@
            #-no-ansi-print-object
            (:print-object (lambda (x s)
                             (print-unreadable-object (x s :type t)
            #-no-ansi-print-object
            (:print-object (lambda (x s)
                             (print-unreadable-object (x s :type t)

-                              (prin1 (class-info-name x))))))
+                              (prin1 (class-info-name x)))))
+           (:copier nil))

   ;; name of this class
   (name nil :type keyword :read-only t)
   ;; 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 DEFINE-INFO-TYPE), then
-;;; generate code to recreate the compile time value, and arrange for that
-;;; code to be called in cold load.
+;;; 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.
+;;; 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)))

@@ -142,16 +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)
                                       (class-info-name (type-info-class x))
                                       (type-info-name x)

-                                      (type-info-number x))))))
+                                      (type-info-number x)))))
+           (:copier nil))

   ;; the name of this type
   ;; 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

@@ -162,12 +170,16 @@
 ;;; 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)))
 

-;;; If Name is the name of a type in Class, then return the TYPE-INFO,
+;;; If NAME is the name of a type in CLASS, then return the TYPE-INFO,

 ;;; otherwise NIL.
 (defun find-type-info (name class)
   (declare (type keyword name) (type class-info class))
 ;;; otherwise NIL.
 (defun find-type-info (name class)
   (declare (type keyword name) (type class-info class))

@@ -179,17 +191,26 @@
 (declaim (ftype (function (keyword) class-info) class-info-or-lose))
 (defun class-info-or-lose (class)
   (declare (type keyword class))
 (declaim (ftype (function (keyword) class-info) class-info-or-lose))
 (defun class-info-or-lose (class)
   (declare (type keyword class))

-  (or (gethash class *info-classes*)
-      (error "~S is not a defined info class." class)))
+  #+sb-xc (/noshow0 "entering CLASS-INFO-OR-LOSE, CLASS=..")
+  #+sb-xc (/nohexstr class)
+  (prog1
+      (or (gethash class *info-classes*)
+         (error "~S is not a defined info class." class))
+    #+sb-xc (/noshow0 "returning from CLASS-INFO-OR-LOSE")))

 (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
 (defun type-info-or-lose (class type)
 (declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
 (defun type-info-or-lose (class type)

-  (or (find-type-info type (class-info-or-lose class))
-      (error "~S is not a defined info type." type)))
+  #+sb-xc (/noshow0 "entering TYPE-INFO-OR-LOSE, CLASS,TYPE=..")
+  #+sb-xc (/nohexstr class)
+  #+sb-xc (/nohexstr type)
+  (prog1
+      (or (find-type-info type (class-info-or-lose class))
+         (error "~S is not a defined info type." type))
+    #+sb-xc (/noshow0 "returning from TYPE-INFO-OR-LOSE")))

 
 ) ; EVAL-WHEN
 \f
 
 ) ; EVAL-WHEN
 \f

-;;;; info classes, info types, and type numbers, part II: what's needed only at
-;;;; compile time, not at run time
+;;;; info classes, info types, and type numbers, part II: what's
+;;;; needed only at compile time, not at run time

 
 ;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS
 ;;; and the calls to it) could/should go in a separate file,
 
 ;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS
 ;;; and the calls to it) could/should go in a separate file,

@@ -197,37 +218,39 @@
 
 (eval-when (:compile-toplevel :execute)
 
 
 (eval-when (:compile-toplevel :execute)
 

-;;; Set up the data structures to support an info class. We make sure that
-;;; the class exists at compile time so that macros can use it, but don't
-;;; actually store the init function until load time so that we don't break the
-;;; running compiler.
+;;; Set up the data structures to support an info class.
+;;;
+;;; comment from CMU CL:
+;;;   We make sure that the class exists at compile time so that
+;;;   macros can use it, but we don't actually store the init function
+;;;   until load time so that we don't break the running compiler.
+;;; KLUDGE: I don't think that's the way it is any more, but I haven't
+;;; looked into it enough to write a better comment. -- WHN 2001-03-06

 (#+sb-xc-host defmacro
  #-sb-xc-host sb!xc:defmacro
      define-info-class (class)
 (#+sb-xc-host defmacro
  #-sb-xc-host sb!xc:defmacro
      define-info-class (class)

-  #!+sb-doc
-  "Define-Info-Class Class
-  Define a new class of global information."

   (declare (type keyword class))
   `(progn
   (declare (type keyword class))
   `(progn

-     ;; (We don't need to evaluate this at load time, compile time is enough.
-     ;; There's special logic elsewhere which deals with cold load
-     ;; initialization by inspecting the info class data structures at compile
-     ;; time and generating code to recreate those data structures.)
+     ;; (We don't need to evaluate this at load time, compile time is
+     ;; enough. There's special logic elsewhere which deals with cold
+     ;; load initialization by inspecting the info class data
+     ;; structures at compile time and generating code to recreate
+     ;; those data structures.)

      (eval-when (:compile-toplevel :execute)
        (unless (gethash ,class *info-classes*)
         (setf (gethash ,class *info-classes*) (make-class-info ,class))))
      ,class))
 
      (eval-when (:compile-toplevel :execute)
        (unless (gethash ,class *info-classes*)
         (setf (gethash ,class *info-classes*) (make-class-info ,class))))
      ,class))
 

-;;; Find a type number not already in use by looking for a null entry in
-;;; *INFO-TYPES*.
+;;; Find a type number not already in use by looking for a null entry
+;;; in *INFO-TYPES*.

 (defun find-unused-type-number ()
   (or (position nil *info-types*)
       (error "no more INFO type numbers available")))
 
 (defun find-unused-type-number ()
   (or (position nil *info-types*)
       (error "no more INFO type numbers available")))
 

-;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO objects,
-;;; accumulated during compilation and eventually converted into a function to
-;;; be called at cold load time after the appropriate TYPE-INFO objects have
-;;; been created
+;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO
+;;; objects, accumulated during compilation and eventually converted
+;;; into a function to be called at cold load time after the
+;;; appropriate TYPE-INFO objects have been created

 ;;;
 ;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
 ;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery
 ;;;
 ;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
 ;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery

@@ -236,33 +259,32 @@
 ;;; 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)
-
-;;; 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.
+(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
 (#+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)

-       ;; At compile time, ensure that the type number exists. It will need
-       ;; to be forced to exist at cold load time, too, but that's not handled
-       ;; here; it's handled by later code which looks at the compile time
-       ;; state and generates code to replicate it at cold load time.
+       ;; At compile time, ensure that the type number exists. It will
+       ;; need to be forced to exist at cold load time, too, but
+       ;; that's not handled here; it's handled by later code which
+       ;; looks at the compile time state and generates code to
+       ;; replicate it at cold load time.

        (let* ((class-info (class-info-or-lose ',class))
              (old-type-info (find-type-info ',type class-info)))
         (unless old-type-info
        (let* ((class-info (class-info-or-lose ',class))
              (old-type-info (find-type-info ',type class-info)))
         (unless old-type-info

@@ -273,40 +295,44 @@
                                   :number new-type-number)))
             (setf (aref *info-types* new-type-number) new-type-info)
             (push new-type-info (class-info-types class-info)))))
                                   :number new-type-number)))
             (setf (aref *info-types* new-type-number) new-type-info)
             (push new-type-info (class-info-types class-info)))))

-       ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set at cold
-       ;; load time. (They can't very well be set at cross-compile time, since
-       ;; they differ between the cross-compiler and the target. The
-       ;; DEFAULT slot values differ because they're compiled closures, and
-       ;; the TYPE slot values differ in the use of SB!XC symbols instead
-       ;; of CL symbols.)
+       ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
+       ;; at cold load time. (They can't very well be set at
+       ;; cross-compile time, since they differ between the
+       ;; cross-compiler and the target. The DEFAULT slot values
+       ;; differ because they're compiled closures, and the TYPE slot
+       ;; values differ in the use of SB!XC symbols instead of CL
+       ;; symbols.)

        (push `(let ((type-info (type-info-or-lose ,',class ,',type)))
                (setf (type-info-default type-info)
        (push `(let ((type-info (type-info-or-lose ,',class ,',type)))
                (setf (type-info-default type-info)

-                      ;; FIXME: This code is sort of nasty. It would be
-                      ;; cleaner if DEFAULT accepted a real function, instead
-                      ;; of accepting a statement which will be turned into a
-                      ;; lambda assuming that the argument name is NAME. It
-                      ;; might even be more microefficient, too, since many
-                      ;; DEFAULTs could be implemented as (CONSTANTLY NIL)
-                      ;; instead of full-blown (LAMBDA (X) NIL).
+                      ;; FIXME: This code is sort of nasty. It would
+                      ;; be cleaner if DEFAULT accepted a real
+                      ;; function, instead of accepting a statement
+                      ;; which will be turned into a lambda assuming
+                      ;; that the argument name is NAME. It might
+                      ;; even be more microefficient, too, since many
+                      ;; DEFAULTs could be implemented as (CONSTANTLY
+                      ;; NIL) instead of full-blown (LAMBDA (X) NIL).

                       (lambda (name)
                         (declare (ignorable name))
                         ,',default))
                (setf (type-info-type type-info) ',',type-spec))
                       (lambda (name)
                         (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
 \f
 ;;;; generic info environments
 
      ',type))
 
 ) ; EVAL-WHEN
 \f
 ;;;; generic info environments
 

-;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping
-;;; reasons. If we access with accessors for the exact type, then the inline
-;;; type check will win. If the inline check didn't win, we would try to use
-;;; the type system before it was properly initialized.
-(defstruct (info-env (:constructor nil))
-  ;; Some string describing what is in this environment, for printing purposes
-  ;; only.
-  (name (required-argument) :type string))
+;;; Note: the CACHE-NAME slot is deliberately not shared for
+;;; bootstrapping reasons. If we access with accessors for the exact
+;;; type, then the inline type check will win. If the inline check
+;;; didn't win, we would try to use the type system before it was
+;;; properly initialized.
+(defstruct (info-env (:constructor nil)
+                    (:copier nil))
+  ;; some string describing what is in this environment, for
+  ;; printing/debugging purposes only
+  (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)))

@@ -330,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

@@ -365,7 +391,8 @@
                             (declare (ignorable ,type-var ,class-var
                                                 ,value-var))
                             ,@body
                             (declare (ignorable ,type-var ,class-var
                                                 ,value-var))
                             ,@body

-                            (unless (zerop (logand ,n-info compact-info-entry-last))
+                            (unless (zerop (logand ,n-info
+                                                   compact-info-entry-last))

                               (return-from ,PUNT))))))))))))))
 
 ;;; Return code to iterate over a volatile info environment.
                               (return-from ,PUNT))))))))))))))
 
 ;;; Return code to iterate over a volatile info environment.

@@ -435,12 +462,12 @@
 (defun clear-invalid-info-cache ()
   ;; Unless the cache is valid..
   (unless (eq *info-environment* *cached-info-environment*)
 (defun clear-invalid-info-cache ()
   ;; Unless the cache is valid..
   (unless (eq *info-environment* *cached-info-environment*)

-    (;; In the target Lisp, this should be done without interrupts, but in the
-     ;; host Lisp when cross-compiling, we don't need to sweat it, since no
-     ;; affected-by-GC hashes should be used when running under the host Lisp
-     ;; (since that's non-portable) and since only one thread should be used
-     ;; when running under the host Lisp (because multiple threads are
-     ;; non-portable too).
+    (;; In the target Lisp, this should be done without interrupts,
+     ;; but in the host Lisp when cross-compiling, we don't need to
+     ;; sweat it, since no affected-by-GC hashes should be used when
+     ;; running under the host Lisp (since that's non-portable) and
+     ;; since only one thread should be used when running under the
+     ;; host Lisp (because multiple threads are non-portable too).

      #-sb-xc-host without-interrupts
      #+sb-xc-host progn
       (info-cache-clear)
      #-sb-xc-host without-interrupts
      #+sb-xc-host progn
       (info-cache-clear)

@@ -449,46 +476,47 @@
 ;;;; 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-entry () `(unsigned-byte ,(1+ type-number-bits)))
 
 (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-entry () `(unsigned-byte ,(1+ type-number-bits)))
 

-;;; This is an open hashtable with rehashing. Since modification is not
-;;; allowed, we don't have to worry about deleted entries. We indirect through
-;;; a parallel vector to find the index in the ENTRIES at which the entries for
-;;; a given name starts.
+;;; This is an open hashtable with rehashing. Since modification is
+;;; not allowed, we don't have to worry about deleted entries. We
+;;; indirect through a parallel vector to find the index in the
+;;; ENTRIES at which the entries for a given name starts.

 (defstruct (compact-info-env (:include info-env)
 (defstruct (compact-info-env (:include info-env)

-                            #-sb-xc-host (:pure :substructure))
-  ;; If this value is EQ to the name we want to look up, then the cache hit
-  ;; function can be called instead of the lookup function.
+                            #-sb-xc-host (:pure :substructure)
+                            (:copier nil))
+  ;; If this value is EQ to the name we want to look up, then the
+  ;; cache hit function can be called instead of the lookup function.

   (cache-name 0)
   (cache-name 0)

-  ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no
-  ;; entries.
+  ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has
+  ;; no entries.

   (cache-index nil :type (or compact-info-entries-index null))
   (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)
-  ;; 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 (*)))
-  ;; 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.
+  ;; hashtable of the names in this environment. If a bucket is
+  ;; unused, it is 0.
+  (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.
+  (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.
+  (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))

@@ -506,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))

@@ -519,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))))

@@ -540,27 +581,29 @@
 
 ;;; 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)

 
 

-;;; Iterate over the environment once to find out how many names and entries
-;;; it has, then build the result. This code assumes that all the entries for
-;;; a name well be iterated over contiguously, which holds true for the
-;;; implementation of iteration over both kinds of environments.
-;;;
-;;; When building the table, we sort the entries by POINTER< in an attempt
-;;; to preserve any VM locality present in the original load order, rather than
-;;; randomizing with the original hash function.
+;;; Return a new compact info environment that holds the same
+;;; information as ENV.

 (defun compact-info-environment (env &key (name (info-env-name env)))
 (defun compact-info-environment (env &key (name (info-env-name env)))

-  #!+sb-doc
-  "Return a new compact info environment that holds the same information as
-  Env."

   (let ((name-count 0)
        (prev-name 0)
        (entry-count 0))
   (let ((name-count 0)
        (prev-name 0)
        (entry-count 0))

+    (/show0 "before COLLECT in COMPACT-INFO-ENVIRONMENT")
+
+    ;; Iterate over the environment once to find out how many names
+    ;; and entries it has, then build the result. This code assumes
+    ;; that all the entries for a name well be iterated over
+    ;; contiguously, which holds true for the implementation of
+    ;; iteration over both kinds of environments.

     (collect ((names))
     (collect ((names))

+
+      (/show0 "at head of COLLECT in COMPACT-INFO-ENVIRONMENT")

       (let ((types ()))
        (do-info (env :name name :type-number num :value value)
       (let ((types ()))
        (do-info (env :name name :type-number num :value value)

+         (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT")

          (unless (eq name prev-name)
          (unless (eq name prev-name)

+            (/noshow0 "not (EQ NAME PREV-NAME) case")

            (incf name-count)
            (unless (eql prev-name 0)
              (names (cons prev-name types)))
            (incf name-count)
            (unless (eql prev-name 0)
              (names (cons prev-name types)))

@@ -569,8 +612,17 @@
          (incf entry-count)
          (push (cons num value) types))
        (unless (eql prev-name 0)
          (incf entry-count)
          (push (cons num value) types))
        (unless (eql prev-name 0)

+          (/show0 "not (EQL PREV-NAME 0) case")

          (names (cons prev-name types))))
 
          (names (cons prev-name types))))
 

+      ;; Now that we know how big the environment is, we can build
+      ;; a table to represent it.
+      ;; 
+      ;; When building the table, we sort the entries by pointer
+      ;; comparison in an attempt to preserve any VM locality present
+      ;; in the original load order, rather than randomizing with the
+      ;; original hash function.
+      (/show0 "about to make/sort vectors in COMPACT-INFO-ENVIRONMENT")

       (let* ((table-size (primify
                          (+ (truncate (* name-count 100)
                                       compact-info-environment-density)
       (let* ((table-size (primify
                          (+ (truncate (* name-count 100)
                                       compact-info-environment-density)

@@ -583,10 +635,12 @@
                                       :element-type 'compact-info-entry))
             (sorted (sort (names)
                           #+sb-xc-host #'<
                                       :element-type 'compact-info-entry))
             (sorted (sort (names)
                           #+sb-xc-host #'<

+                          ;; (This MAKE-FIXNUM hack implements
+                          ;; pointer comparison, as explained above.)

                           #-sb-xc-host (lambda (x y)
                           #-sb-xc-host (lambda (x y)

-                                         ;; FIXME: What's going on here?

                                          (< (%primitive make-fixnum x)
                                             (%primitive make-fixnum y))))))
                                          (< (%primitive make-fixnum x)
                                             (%primitive make-fixnum y))))))

+       (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")

        (let ((entries-idx 0))
          (dolist (types sorted)
            (let* ((name (first types))
        (let ((entries-idx 0))
          (dolist (types sorted)
            (let* ((name (first types))

@@ -601,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))

@@ -612,12 +666,15 @@
              (setf (aref entries-info entries-idx) num)
              (setf (aref entries entries-idx) value)
              (incf entries-idx)))
              (setf (aref entries-info entries-idx) num)
              (setf (aref entries entries-idx) value)
              (incf entries-idx)))

+         (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT")

 
          (unless (zerop entry-count)
 
          (unless (zerop entry-count)

+           (/show0 "nonZEROP ENTRY-COUNT")

            (setf (aref entries-info (1- entry-count))
                  (logior (aref entries-info (1- entry-count))
                          compact-info-entry-last)))
 
            (setf (aref entries-info (1- entry-count))
                  (logior (aref entries-info (1- entry-count))
                          compact-info-entry-last)))
 

+         (/show0 "falling through to MAKE-COMPACT-INFO-ENV")

          (make-compact-info-env :name name
                                 :table table
                                 :index index
          (make-compact-info-env :name name
                                 :table table
                                 :index index

@@ -626,22 +683,23 @@
 \f
 ;;;; volatile environments
 
 \f
 ;;;; volatile environments
 

-;;; This is a closed hashtable, with the bucket being computed by taking the
-;;; GLOBALDB-SXHASHOID of the Name mod the table size.
-(defstruct (volatile-info-env (:include info-env))
-  ;; If this value is EQ to the name we want to look up, then the cache hit
-  ;; function can be called instead of the lookup function.
+;;; This is a closed hashtable, with the bucket being computed by
+;;; taking the GLOBALDB-SXHASHOID of the NAME modulo the table size.
+(defstruct (volatile-info-env (:include info-env)
+                             (:copier nil))
+  ;; If this value is EQ to the name we want to look up, then the
+  ;; cache hit function can be called instead of the lookup function.

   (cache-name 0)
   (cache-name 0)

-  ;; The alist translating type numbers to values for the currently cached
-  ;; name.
+  ;; the alist translating type numbers to values for the currently
+  ;; cached name

   (cache-types nil :type list)
   (cache-types nil :type list)

-  ;; Vector of alists of alists of the form:
+  ;; vector of alists of alists of the form:

   ;;    ((Name . ((Type-Number . Value) ...) ...)
   ;;    ((Name . ((Type-Number . Value) ...) ...)

-  (table (required-argument) :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.
+  (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)
   (count 0 :type index)

-  ;; The number of names at which we should grow the table and rehash.
+  ;; the number of names at which we should grow the table and rehash

   (threshold 0 :type index))
 
 ;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
   (threshold 0 :type index))
 
 ;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.

@@ -654,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))) ())

@@ -665,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

@@ -751,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

@@ -784,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.

@@ -829,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"))

@@ -840,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

@@ -885,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))

@@ -912,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

@@ -933,17 +1005,18 @@
 
 (define-info-class :function)
 
 
 (define-info-class :function)
 

-;;; The kind of functional object being described. If null, Name isn't a known
-;;; functional object.
+;;; the kind of functional object being described. If null, NAME isn't
+;;; a known functional object.

 (define-info-type
   :class :function
   :type :kind
   :type-spec (member nil :function :macro :special-form)
 (define-info-type
   :class :function
   :type :kind
   :type-spec (member nil :function :macro :special-form)

-  ;; I'm a little confused what the correct behavior of this default is. It's
-  ;; not clear how to generalize the FBOUNDP expression to the cross-compiler.
-  ;; As far as I can tell, NIL is a safe default -- it might keep the compiler
-  ;; from making some valid optimization, but it shouldn't produce incorrect
-  ;; code. -- WHN 19990330
+  ;; I'm a little confused what the correct behavior of this default
+  ;; is. It's not clear how to generalize the FBOUNDP expression to
+  ;; the cross-compiler. As far as I can tell, NIL is a safe default
+  ;; -- it might keep the compiler from making some valid
+  ;; optimization, but it shouldn't produce incorrect code. -- WHN
+  ;; 19990330

   :default
   #+sb-xc-host nil
   #-sb-xc-host (if (fboundp name) :function nil))
   :default
   #+sb-xc-host nil
   #-sb-xc-host (if (fboundp name) :function nil))

@@ -953,31 +1026,34 @@
   :class :function
   :type :type
   :type-spec ctype
   :class :function
   :type :type
   :type-spec ctype

-  ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's not clear
-  ;; how to generalize the FBOUNDP expression to the cross-compiler.
-  ;;  -- WHN 19990330
+  ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
+  ;; not clear how to generalize the FBOUNDP expression to the
+  ;; cross-compiler. -- WHN 19990330

   :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)))
 
                   (specifier-type 'function)))
 

-;;; The Assumed-Type for this function, if we have to infer the type due to not
-;;; having a declaration or definition.
+;;; the ASSUMED-TYPE for this function, if we have to infer the type
+;;; due to not having a declaration or definition

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

-  :type-spec (or approximate-function-type null))
-
-;;; 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
+  ;; FIXME: The type-spec really should be
+  ;;   (or approximate-fun-type null)).
+  ;; It was changed to T as a hopefully-temporary hack while getting
+  ;; cold init problems untangled.
+  :type-spec t)
+
+;;; where this information came from:
+;;;    :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

@@ -989,69 +1065,74 @@
   #+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)

 
 

-;;; 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.

 (define-info-type
   :class :function
   :type :inlinep
   :type-spec inlinep
   :default nil)
 
 (define-info-type
   :class :function
   :type :inlinep
   :type-spec inlinep
   :default nil)
 

-;;; A macro-like function which transforms a call to this function
+;;; a macro-like function which transforms a call to this function

 ;;; into some other Lisp form. This expansion is inhibited if inline
 ;;; into some other Lisp form. This expansion is inhibited if inline

-;;; expansion is inhibited.
+;;; expansion is inhibited

 (define-info-type
   :class :function
   :type :source-transform
   :type-spec (or function null))
 
 (define-info-type
   :class :function
   :type :source-transform
   :type-spec (or function null))
 

-;;; The macroexpansion function for this macro.
+;;; the macroexpansion function for this macro

 (define-info-type
   :class :function
   :type :macro-function
   :type-spec (or function null)
   :default nil)
 
 (define-info-type
   :class :function
   :type :macro-function
   :type-spec (or function null)
   :default nil)
 

-;;; The compiler-macroexpansion function for this macro.
+;;; the compiler-macroexpansion function for this macro

 (define-info-type
   :class :function
   :type :compiler-macro-function
   :type-spec (or function null)
   :default nil)
 
 (define-info-type
   :class :function
   :type :compiler-macro-function
   :type-spec (or function null)
   :default nil)
 

-;;; A function which converts this special form into IR1.
+;;; a function which converts this special form into IR1

 (define-info-type
   :class :function
   :type :ir1-convert
   :type-spec (or function null))
 
 (define-info-type
   :class :function
   :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 FUNCTION-INFO
+;;; 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
 ;;; structure containing the info used to special-case compilation.
 (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

@@ -1063,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

@@ -1117,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

@@ -1137,42 +1234,43 @@
   :type :documentation
   :type-spec (or string null))
 
   :type :documentation
   :type-spec (or string null))
 

-;;; Function that parses type specifiers into CTYPE structures.
+;;; function that parses type specifiers into CTYPE structures

 (define-info-type
   :class :type
   :type :translator
   :type-spec (or function null)
   :default nil)
 
 (define-info-type
   :class :type
   :type :translator
   :type-spec (or function null)
   :default nil)
 

-;;; If true, then the type coresponding to this name. Note that if this is a
-;;; built-in class with a translation, then this is the translation, not the
-;;; class object. This info type keeps track of various atomic types (NIL etc.)
-;;; and also serves as a cache to ensure that common standard types (atomic and
-;;; otherwise) are only consed once.
+;;; If true, then the type coresponding to this name. Note that if
+;;; this is a built-in class with a translation, then this is the
+;;; translation, not the class object. This info type keeps track of
+;;; various atomic types (NIL etc.) and also serves as a cache to
+;;; ensure that common standard types (atomic and otherwise) are only
+;;; consed once.

 (define-info-type
   :class :type
   :type :builtin
   :type-spec (or ctype null)
   :default nil)
 
 (define-info-type
   :class :type
   :type :builtin
   :type-spec (or ctype null)
   :default nil)
 

-;;; 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 meaningful error if we only
-;;; have the cons.
+;;; 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 name is in the cons so that we can signal a
+;;; meaningful error if we only have the cons.

 (define-info-type
   :class :type
 (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)
 
   :default nil)
 

-;;; Layout for this type being used by the compiler.
+;;; layout for this type being used by the compiler

 (define-info-type
   :class :type
   :type :compiler-layout
   :type-spec (or layout null)
 (define-info-type
   :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

@@ -1239,8 +1337,8 @@
   :type-spec (or function null)
   :default nil)
 
   :type-spec (or function null)
   :default nil)
 

-;;; Used for storing miscellaneous documentation types. The stuff is an alist
-;;; translating documentation kinds to values.
+;;; This is used for storing miscellaneous documentation types. The
+;;; stuff is an alist translating documentation kinds to values.

 (define-info-class :random-documentation)
 (define-info-type
   :class :random-documentation
 (define-info-class :random-documentation)
 (define-info-type
   :class :random-documentation

@@ -1250,18 +1348,13 @@
 
 #!-sb-fluid (declaim (freeze-type info-env))
 \f
 
 #!-sb-fluid (declaim (freeze-type info-env))
 \f

-;;; Now that we have finished initializing *INFO-CLASSES* and *INFO-TYPES* (at
-;;; compile time), generate code to set them at cold load time to the same
-;;; state they have currently.
+;;; Now that we have finished initializing *INFO-CLASSES* and
+;;; *INFO-TYPES* (at compile time), generate code to set them at cold
+;;; load time to the same state they have currently.

 (!cold-init-forms
   (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
   (setf *info-classes*
 (!cold-init-forms
   (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
   (setf *info-classes*

-       (make-hash-table :size #.(hash-table-size *info-classes*)
-                        ;; FIXME: These remaining arguments are only here
-                        ;; for debugging, to try track down weird cold
-                        ;; boot problems.
-                        #|:rehash-size 1.5
-                        :rehash-threshold 1|#))
+       (make-hash-table :size #.(hash-table-size *info-classes*)))

   (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
   (dolist (class-info-name '#.(let ((result nil))
                                (maphash (lambda (key value)
   (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
   (dolist (class-info-name '#.(let ((result nil))
                                (maphash (lambda (key value)

@@ -1277,12 +1370,15 @@
   (setf *info-types*
        (map 'vector
             (lambda (x)
   (setf *info-types*
        (map 'vector
             (lambda (x)

+              (/show0 "in LAMBDA (X), X=..")
+              (/hexstr x)

               (when x
                 (let* ((class-info (class-info-or-lose (second x)))
                        (type-info (make-type-info :name (first x)
                                                   :class class-info
                                                   :number (third x)
                                                   :type (fourth x))))
               (when x
                 (let* ((class-info (class-info-or-lose (second x)))
                        (type-info (make-type-info :name (first x)
                                                   :class class-info
                                                   :number (third x)
                                                   :type (fourth x))))

+                  (/show0 "got CLASS-INFO in LAMBDA (X)")

                   (push type-info (class-info-types class-info))
                   type-info)))
             '#.(map 'list
                   (push type-info (class-info-types class-info))
                   type-info)))
             '#.(map 'list

@@ -1295,11 +1391,11 @@
                     *info-types*)))
   (/show0 "done with *INFO-TYPES* initialization"))
 
                     *info-types*)))
   (/show0 "done with *INFO-TYPES* initialization"))
 

-;;; At cold load time, after the INFO-TYPE objects have been created, we can
-;;; set their DEFAULT and TYPE slots.
+;;; At cold load time, after the INFO-TYPE objects have been created,
+;;; we can set their DEFAULT and TYPE slots.

 (macrolet ((frob ()
             `(!cold-init-forms
 (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

@@ -1309,11 +1405,11 @@
 ;;;;     ..)
 ;;;;   (DEFSETF BAR SET-BAR) ; can't influence previous compilation
 ;;;;
 ;;;;     ..)
 ;;;;   (DEFSETF BAR SET-BAR) ; can't influence previous compilation
 ;;;;

-;;;; KLUDGE: Arguably it should be another class/type combination in the
-;;;; globaldb. However, IMHO the whole globaldb/fdefinition treatment of setf
-;;;; functions is a mess which ought to be rewritten, and I'm not inclined to
-;;;; mess with it short of that. So I just put this bag on the side of it
-;;;; instead..
+;;;; KLUDGE: Arguably it should be another class/type combination in
+;;;; the globaldb. However, IMHO the whole globaldb/fdefinition
+;;;; treatment of SETF functions is a mess which ought to be
+;;;; rewritten, and I'm not inclined to mess with it short of that. So
+;;;; I just put this bag on the side of it instead..

 
 ;;; true for symbols FOO which have been assumed to have '(SETF FOO)
 ;;; bound to a function
 
 ;;; true for symbols FOO which have been assumed to have '(SETF FOO)
 ;;; bound to a function