0.8.13.12:

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

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index c960c69..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.

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

@@ -262,7 +259,7 @@
 ;;; 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
 
 ;;; 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

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

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

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

@@ -515,8 +512,8 @@
   ;; last entry.
   (entries-info (missing-arg) :type (simple-array compact-info-entry (*))))
 
   ;; last entry.
   (entries-info (missing-arg) :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))
+(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.
 
 ;;; Return the value of the type corresponding to NUMBER for the
 ;;; currently cached name in ENV.

@@ -540,7 +537,20 @@
 ;;; Encache NAME in the compact environment ENV. HASH is the
 ;;; GLOBALDB-SXHASHOID of NAME.
 (defun compact-info-lookup (env name hash)
 ;;; Encache NAME in the compact environment ENV. HASH is the
 ;;; GLOBALDB-SXHASHOID of NAME.
 (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))

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

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

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

@@ -818,15 +829,14 @@
   ;; 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))
   ;; 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))
-           (value (gensym "VALUE"))
-           (foundp (gensym "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)))
+      (let ((info (type-info-or-lose class type)))
+       (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

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

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

@@ -896,7 +906,6 @@
 ;;; the current environment, allowing any inherited info to become
 ;;; visible. We return true if there was any info.
 (defun clear-info (class type name)
 ;;; the current environment, allowing any inherited info to become
 ;;; visible. We return true if there was any info.
 (defun clear-info (class type name)

-  #!+sb-doc

   (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

@@ -1035,7 +1044,7 @@
   ;;   (or approximate-fun-type null)).
   ;; It was changed to T as a hopefully-temporary hack while getting
   ;; cold init problems untangled.
   ;;   (or approximate-fun-type null)).
   ;; 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:
 ;;;    :ASSUMED  = from uses of the object
 
 ;;; where this information came from:
 ;;;    :ASSUMED  = from uses of the object

@@ -1118,13 +1127,6 @@
   :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 "known" to the compiler, then this is a FUN-INFO
 ;;; structure containing the info used to special-case compilation.
 (define-info-type
 ;;; 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

@@ -1142,7 +1144,7 @@
 (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
   :default nil)
 \f
 ;;;; definitions for other miscellaneous information

@@ -1153,7 +1155,7 @@
 (define-info-type
   :class :variable
   :type :kind
 (define-info-type
   :class :variable
   :type :kind

-  :type-spec (member :special :constant :global :alien)
+  :type-spec (member :special :constant :macro :global :alien)

   :default (if (symbol-self-evaluating-p name)
               :constant
               :global))
   :default (if (symbol-self-evaluating-p name)
               :constant
               :global))

@@ -1188,6 +1190,13 @@
               name
               (bug "constant lookup of nonconstant ~S" 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
   :type :alien-info
 (define-info-type
   :class :variable
   :type :alien-info

@@ -1203,11 +1212,14 @@
 (define-info-class :type)
 
 ;;; the kind of type described. We return :INSTANCE for standard types
 (define-info-class :type)
 
 ;;; the kind of type described. We return :INSTANCE for standard types

-;;; that are implemented as structures.
+;;; 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)
 
 ;;; the expander function for a defined type
   :default nil)
 
 ;;; the expander function for a defined type

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

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

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