X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=3e38ef773ea3eee3d80c55a9787491a5a852d47e;hb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;hp=6f08a8b77c4b44c901b8a3be86af6f92368ca9b2;hpb=1ab8bfcc2145a100795401de5941c373bb6318eb;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 6f08a8b..3e38ef7 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -241,7 +241,20 @@
                        (type (type-specifier (info :variable :type name))))
                    `(macro . (the ,type ,expansion))))
                 (:constant
-                 (find-constant (info :variable :constant-value name)))
+                 (let ((value (symbol-value name)))
+                   ;; Override the values of standard symbols in XC,
+                   ;; since we can't redefine them.
+                   #+sb-xc-host
+                   (when (eql (find-symbol (symbol-name name) :cl) name)
+                     (multiple-value-bind (xc-value foundp)
+                         (info :variable :xc-constant-value name)
+                       (cond (foundp
+                              (setf value xc-value))
+                             ((not (eq value name))
+                              (compiler-warn
+                               "Using cross-compilation host's definition of ~S: ~A~%"
+                               name (symbol-value name))))))
+                   (find-constant value name)))
                 (t
                  (make-global-var :kind kind
                                   :%source-name name
@@ -252,43 +265,24 @@
 ;;; processed with MAKE-LOAD-FORM. We have to be careful, because
 ;;; CONSTANT might be circular. We also check that the constant (and
 ;;; any subparts) are dumpable at all.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
-  ;; below. -- AL 20010227
-  (def!constant list-to-hash-table-threshold 32))
-(defun maybe-emit-make-load-forms (constant)
-  (let ((things-processed nil)
-        (count 0))
-    ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit?
-    (declare (type (or list hash-table) things-processed)
-             (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
-             (inline member))
-    (labels ((grovel (value)
+(defun maybe-emit-make-load-forms (constant &optional (name nil namep))
+  (let ((xset (alloc-xset)))
+    (labels ((trivialp (value)
+               (typep value
+                      '(or
+                        #-sb-xc-host unboxed-array
+                        #+sb-xc-host (simple-array (unsigned-byte 8) (*))
+                        symbol
+                        number
+                        character
+                        string)))
+             (grovel (value)
                ;; Unless VALUE is an object which which obviously
                ;; can't contain other objects
-               (unless (typep value
-                              '(or #-sb-xc-host unboxed-array
-                                   #+sb-xc-host (simple-array (unsigned-byte 8) (*))
-                                   symbol
-                                   number
-                                   character
-                                   string))
-                 (etypecase things-processed
-                   (list
-                    (when (member value things-processed :test #'eq)
-                      (return-from grovel nil))
-                    (push value things-processed)
-                    (incf count)
-                    (when (> count list-to-hash-table-threshold)
-                      (let ((things things-processed))
-                        (setf things-processed
-                              (make-hash-table :test 'eq))
-                        (dolist (thing things)
-                          (setf (gethash thing things-processed) t)))))
-                   (hash-table
-                    (when (gethash value things-processed)
-                      (return-from grovel nil))
-                    (setf (gethash value things-processed) t)))
+               (unless (trivialp value)
+                 (if (xset-member-p value xset)
+                     (return-from grovel nil)
+                     (add-to-xset value xset))
                  (typecase value
                    (cons
                     (grovel (car value))
@@ -309,12 +303,15 @@
                    ((array t)
                     (dotimes (i (array-total-size value))
                       (grovel (row-major-aref value i))))
-                   (;; In the target SBCL, we can dump any instance,
-                    ;; but in the cross-compilation host,
-                    ;; %INSTANCE-FOO functions don't work on general
-                    ;; instances, only on STRUCTURE!OBJECTs.
-                    #+sb-xc-host structure!object
+                   (#+sb-xc-host structure!object
                     #-sb-xc-host instance
+                    ;; In the target SBCL, we can dump any instance, but
+                    ;; in the cross-compilation host, %INSTANCE-FOO
+                    ;; functions don't work on general instances, only on
+                    ;; STRUCTURE!OBJECTs.
+                    ;;
+                    ;; FIXME: What about funcallable instances with
+                    ;; user-defined MAKE-LOAD-FORM methods?
                     (when (emit-make-load-form value)
                       (dotimes (i (- (%instance-length value)
                                      #+sb-xc-host 0
@@ -325,7 +322,15 @@
                     (compiler-error
                      "Objects of type ~S can't be dumped into fasl files."
                      (type-of value)))))))
-      (grovel constant)))
+      ;; Dump all non-trivial named constants using the name.
+      (if (and namep (not (typep constant '(or symbol character
+                                            ;; FIXME: Cold init breaks if we
+                                            ;; try to reference FP constants
+                                            ;; thru their names.
+                                            #+sb-xc-host number
+                                            #-sb-xc-host fixnum))))
+          (emit-make-load-form constant name)
+          (grovel constant))))
   (values))
 
 ;;;; some flow-graph hacking utilities