0.8.18.14:

[sbcl.git] / src / compiler / generic / genesis.lisp

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index fdfa848..fd4cbfc 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -663,6 +663,30 @@ core and return a descriptor to it."
     (write-wordindexed des 2 second)
     des))
 
+(defun write-double-float-bits (address index x)
+  (let ((hi (double-float-high-bits x))
+       (lo (double-float-low-bits x)))
+    (ecase sb!vm::n-word-bits
+      (32
+       (let ((high-bits (make-random-descriptor hi))
+            (low-bits (make-random-descriptor lo)))
+        (ecase sb!c:*backend-byte-order*
+          (:little-endian
+           (write-wordindexed address index low-bits)
+           (write-wordindexed address index high-bits))
+          (:big-endian
+           (write-wordindexed address index high-bits)
+           (write-wordindexed address (1+ index) low-bits)))))
+      (64
+       (let ((bits (make-random-descriptor
+                   (ecase sb!c:*backend-byte-order*
+                     (:little-endian (logior lo (ash hi 32)))
+                     ;; Just guessing.
+                     #+nil (:big-endian (logior (logand hi #xffffffff)
+                                                (ash lo 32)))))))
+        (write-wordindexed address index bits))))
+    address))
+
 (defun float-to-core (x)
   (etypecase x
     (single-float
@@ -678,17 +702,8 @@ core and return a descriptor to it."
      (let ((des (allocate-unboxed-object *dynamic*
                                         sb!vm:n-word-bits
                                         (1- sb!vm:double-float-size)
-                                        sb!vm:double-float-widetag))
-          (high-bits (make-random-descriptor (double-float-high-bits x)))
-          (low-bits (make-random-descriptor (double-float-low-bits x))))
-       (ecase sb!c:*backend-byte-order*
-        (:little-endian
-         (write-wordindexed des sb!vm:double-float-value-slot low-bits)
-         (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
-        (:big-endian
-         (write-wordindexed des sb!vm:double-float-value-slot high-bits)
-         (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
-       des))))
+                                        sb!vm:double-float-widetag)))
+       (write-double-float-bits des sb!vm:double-float-value-slot x)))))
 
 (defun complex-single-float-to-core (num)
   (declare (type (complex single-float) num))
@@ -706,39 +721,10 @@ core and return a descriptor to it."
   (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                      (1- sb!vm:complex-double-float-size)
                                      sb!vm:complex-double-float-widetag)))
-    (let* ((real (realpart num))
-          (high-bits (make-random-descriptor (double-float-high-bits real)))
-          (low-bits (make-random-descriptor (double-float-low-bits real))))
-      (ecase sb!c:*backend-byte-order*
-       (:little-endian
-        (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-real-slot)
-                           high-bits))
-       (:big-endian
-        (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-real-slot)
-                           low-bits))))
-    (let* ((imag (imagpart num))
-          (high-bits (make-random-descriptor (double-float-high-bits imag)))
-          (low-bits (make-random-descriptor (double-float-low-bits imag))))
-      (ecase sb!c:*backend-byte-order*
-       (:little-endian
-        (write-wordindexed des
-                           sb!vm:complex-double-float-imag-slot
-                           low-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-imag-slot)
-                           high-bits))
-       (:big-endian
-        (write-wordindexed des
-                           sb!vm:complex-double-float-imag-slot
-                           high-bits)
-        (write-wordindexed des
-                           (1+ sb!vm:complex-double-float-imag-slot)
-                           low-bits))))
-    des))
+    (write-double-float-bits des sb!vm:complex-double-float-real-slot
+                            (realpart num))
+    (write-double-float-bits des sb!vm:complex-double-float-imag-slot
+                            (imagpart num))))
 
 ;;; Copy the given number to the core.
 (defun number-to-core (number)
@@ -2455,12 +2441,12 @@ core and return a descriptor to it."
                       ;; itself.) Ask on the mailing list whether
                       ;; this is documented somewhere, and if not,
                       ;; try to reverse engineer some documentation.
-                      #!-x86
+                      #!-(or x86 x86-64)
                       ;; a pointer back to the function object, as
                       ;; described in CMU CL
                       ;; src/docs/internals/object.tex
                       fn
-                      #!+x86
+                      #!+(or x86 x86-64)
                       ;; KLUDGE: a pointer to the actual code of the
                       ;; object, as described nowhere that I can find
                       ;; -- WHN 19990907
@@ -3106,7 +3092,7 @@ initially undefined function references:~2%")
                              sb!vm:unbound-marker-widetag))
           *cold-assembler-fixups*
           *cold-assembler-routines*
-          #!+x86 *load-time-code-fixups*)
+          #!+(or x86 x86-64) *load-time-code-fixups*)
 
       ;; Prepare for cold load.
       (initialize-non-nil-symbols)
@@ -3174,7 +3160,7 @@ initially undefined function references:~2%")
 
       ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
       (resolve-assembler-fixups)
-      #!+x86 (output-load-time-code-fixups)
+      #!+(or x86 x86-64) (output-load-time-code-fixups)
       (foreign-symbols-to-core)
       (finish-symbols)
       (/show "back from FINISH-SYMBOLS")