0.8.13.12:

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

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

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

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

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

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

@@ -714,7 +725,6 @@
                (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))
 
 ;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table
   (values))
 
 ;;; Given a volatile environment ENV, bind TABLE-VAR the environment's table

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

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