X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fglobaldb.lisp;h=e55bc34d5d81f1b908461124c8d1f03e36eb5990;hb=91e1d65670542ceb7c177423f25b53d250c9d9cb;hp=45e10d8d6e09793d921ac2aca56e238a68148af3;hpb=c103e75ed3eaf47bda3407d663fd64f09215dc11;p=sbcl.git

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 45e10d8..e55bc34 100644
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -583,11 +583,11 @@
                                        :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)
@@ -788,27 +788,33 @@
                         new-value)))
   new-value)
 #!-sb-fluid
-(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.
-  (if (and (keywordp class) (keywordp type))
-      (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))))
-  whole)
+(progn
+  ;; Not all xc hosts are happy about SETF compiler macros: CMUCL 19
+  ;; 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))
+    ;; Constant CLASS and TYPE is an overwhelmingly common special case,
+    ;; and we can resolve it much more efficiently than the general
+    ;; case.
+    (if (and (keywordp class) (keywordp type))
+        (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))))
+    whole))
 
 ;;; the maximum density of the hashtable in a volatile env (in
 ;;; names/bucket)
@@ -930,7 +936,7 @@
   :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
@@ -1044,6 +1050,12 @@
   :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)
 
 ;;;; definitions for other miscellaneous information