1.0.27.40: host-invariant string constant coalescing
[sbcl.git] / src / compiler / globaldb.lisp
index 1f1eeb5..202893c 100644 (file)
                                        :element-type 'compact-info-entry))
              (sorted (sort (names)
                            #+sb-xc-host #'<
-                           ;; (This MAKE-FIXNUM hack implements
-                           ;; pointer comparison, as explained above.)
+                           ;; POINTER-HASH hack implements pointer
+                           ;; comparison, as explained above.
                            #-sb-xc-host (lambda (x y)
-                                          (< (%primitive make-fixnum x)
-                                             (%primitive make-fixnum y))))))
+                                          (< (pointer-hash x)
+                                             (pointer-hash y))))))
         (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")
         (let ((entries-idx 0))
           (dolist (types sorted)
   ;; Constant CLASS and TYPE is an overwhelmingly common special case,
   ;; and we can implement it much more efficiently than the general case.
   (if (and (keywordp class) (keywordp type))
-      (let ((info (type-info-or-lose class type)))
+      (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+            (info (type-info-or-lose class type)))
         (with-unique-names (value foundp)
           `(multiple-value-bind (,value ,foundp)
                (get-info-value ,name
              (values ,value ,foundp))))
       whole))
 
-(defun (setf info) (new-value
-                    class
-                    type
-                    name
-                    &optional (env-list nil env-list-p))
+(defun (setf info)
+    (new-value class type name &optional (env-list nil env-list-p))
   (let* ((info (type-info-or-lose class type))
          (tin (type-info-number info)))
     (when (type-info-validate-function info)
   ;; does not accept them at all, and older SBCLs give a full warning.
   ;; So the easy thing is to hide this optimization from all xc hosts.
   #-sb-xc-host
-  (define-compiler-macro (setf info) (&whole whole
-                                             new-value
-                                             class
-                                             type
-                                             name
-                                             &optional (env-list nil
-                                                                 env-list-p))
+  (define-compiler-macro (setf info)
+      (&whole whole new-value 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.
   :default
   #+sb-xc-host (specifier-type 'function)
   #-sb-xc-host (if (fboundp name)
-                   (extract-fun-type (fdefinition name))
+                   (specifier-type (sb!impl::%fun-type (fdefinition name)))
                    (specifier-type 'function)))
 
 ;;; the ASSUMED-TYPE for this function, if we have to infer the type
 ;;; where this information came from:
 ;;;    :ASSUMED  = from uses of the object
 ;;;    :DEFINED  = from examination of the definition
+;;;    :DEFINED-METHOD = implicit, incremental declaration by CLOS.
 ;;;    :DECLARED = from a declaration
-;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED trumps :ASSUMED, :DEFINED-METHOD trumps :DEFINED,
+;;; and :DECLARED trumps :DEFINED-METHOD.
 ;;; :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.
+;;; :DEFINED-METHOD and :DECLARED are 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
-  :type-spec (member :declared :assumed :defined)
+  :type-spec (member :declared :defined-method :assumed :defined)
   :default
   ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
   ;; not clear how to generalize the FBOUNDP expression to the
   :type :definition
   :type-spec (or fdefn null)
   :default nil)
+
+(define-info-type
+  :class :function
+  :type :structure-accessor
+  :type-spec (or defstruct-description null)
+  :default nil)
 \f
 ;;;; definitions for other miscellaneous information
 
   :class :variable
   :type :kind
   :type-spec (member :special :constant :macro :global :alien)
-  :default (if (symbol-self-evaluating-p name)
+  :default (if (typep name '(or boolean keyword))
                :constant
                :global))
 
   :type-spec (member :declared :assumed :defined)
   :default :assumed)
 
-;;; the Lisp object which is the value of this constant, if known
+;;; We only need a mechanism different from the
+;;; usual SYMBOL-VALUE for the cross compiler.
+#+sb-xc-host
 (define-info-type
   :class :variable
-  :type :constant-value
+  :type :xc-constant-value
   :type-spec t
-  ;; 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)))
+  :default nil)
 
 ;;; the macro-expansion for symbol-macros
 (define-info-type
   :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 name is in the cons so that we can signal a
-;;; meaningful error if we only have the cons.
-(define-info-type
-  :class :type
-  :type :classoid
-  :type-spec (or sb!kernel::classoid-cell null)
-  :default nil)
-
 ;;; layout for this type being used by the compiler
 (define-info-type
   :class :type
   :default (let ((class (find-classoid name nil)))
              (when class (classoid-layout class))))
 
+;;; DEFTYPE lambda-list
+(define-info-type
+   :class :type
+   :type :lambda-list
+   :type-spec list
+   :default nil)
+
+(define-info-type
+   :class :type
+   :type :source-location
+   :type-spec t
+   :default nil)
+
 (define-info-class :typed-structure)
 (define-info-type
   :class :typed-structure