X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=db3ca48423d846ce8de1fcbbbb5396f7aba079ee;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=af7bb4f052e0f3628ea116f303a20a0abec70dee;hpb=fb2f167e3ea360de1eb1c436de948df5086a6292;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index af7bb4f..db3ca48 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -735,10 +735,17 @@ core and return a descriptor to it."
   (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                       (1- sb!vm:complex-single-float-size)
                                       sb!vm:complex-single-float-widetag)))
-    (write-wordindexed des sb!vm:complex-single-float-real-slot
-                   (make-random-descriptor (single-float-bits (realpart num))))
-    (write-wordindexed des sb!vm:complex-single-float-imag-slot
-                   (make-random-descriptor (single-float-bits (imagpart num))))
+    #!-x86-64
+    (progn
+      (write-wordindexed des sb!vm:complex-single-float-real-slot
+                         (make-random-descriptor (single-float-bits (realpart num))))
+      (write-wordindexed des sb!vm:complex-single-float-imag-slot
+                         (make-random-descriptor (single-float-bits (imagpart num)))))
+    #!+x86-64
+    (write-wordindexed des sb!vm:complex-single-float-data-slot
+                       (make-random-descriptor
+                        (logior (ldb (byte 32 0) (single-float-bits (realpart num)))
+                                (ash (single-float-bits (imagpart num)) 32))))
     des))
 
 (defun complex-double-float-to-core (num)
@@ -2265,6 +2272,7 @@ core and return a descriptor to it."
     (write-wordindexed result sb!vm:array-data-slot data-vector)
     (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
     (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
+    (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*)
     (let ((total-elements 1))
       (dotimes (axis rank)
         (let ((dim (pop-stack)))
@@ -2491,7 +2499,7 @@ core and return a descriptor to it."
     (write-wordindexed code slot value)))
 
 (define-cold-fop (fop-fun-entry)
-  (let* ((xrefs (pop-stack))
+  (let* ((info (pop-stack))
          (type (pop-stack))
          (arglist (pop-stack))
          (name (pop-stack))
@@ -2549,7 +2557,7 @@ core and return a descriptor to it."
     (write-wordindexed fn sb!vm:simple-fun-name-slot name)
     (write-wordindexed fn sb!vm:simple-fun-arglist-slot arglist)
     (write-wordindexed fn sb!vm:simple-fun-type-slot type)
-    (write-wordindexed fn sb!vm::simple-fun-xrefs-slot xrefs)
+    (write-wordindexed fn sb!vm::simple-fun-info-slot info)
     fn))
 
 (define-cold-fop (fop-foreign-fixup)
@@ -2859,7 +2867,36 @@ core and return a descriptor to it."
             (c-symbol-name symbol)
             (sb!xc:mask-field (symbol-value symbol) -1))))
 
-
+#!+sb-ldb
+(defun write-tagnames-h (&optional (out *standard-output*))
+  (labels
+      ((pretty-name (symbol strip)
+         (let ((name (string-downcase symbol)))
+           (substitute #\Space #\-
+                       (subseq name 0 (- (length name) (length strip))))))
+       (list-sorted-tags (tail)
+         (loop for symbol being the external-symbols of "SB!VM"
+               when (and (constantp symbol)
+                         (tailwise-equal (string symbol) tail))
+               collect symbol into tags
+               finally (return (sort tags #'< :key #'symbol-value))))
+       (write-tags (kind limit ash-count)
+         (format out "~%static const char *~(~A~)_names[] = {~%"
+                 (subseq kind 1))
+         (let ((tags (list-sorted-tags kind)))
+           (dotimes (i limit)
+             (if (eql i (ash (or (symbol-value (first tags)) -1) ash-count))
+                 (format out "    \"~A\"" (pretty-name (pop tags) kind))
+                 (format out "    \"unknown [~D]\"" i))
+             (unless (eql i (1- limit))
+               (write-string "," out))
+             (terpri out)))
+         (write-line "};" out)))
+    (write-tags "-LOWTAG" sb!vm:lowtag-limit 0)
+    ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG
+    ;; ending with the same 2 bits. (#b10)
+    (write-tags "-WIDETAG" (ash (1+ sb!vm:widetag-mask) -2) -2))
+  (values))
 
 (defun write-primitive-object (obj)
   ;; writing primitive object layouts
@@ -3347,6 +3384,8 @@ initially undefined function references:~2%")
             (write-map)))
         (out-to "config" (write-config-h))
         (out-to "constants" (write-constants-h))
+        #!+sb-ldb
+        (out-to "tagnames" (write-tagnames-h))
         (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
                              :key (lambda (obj)
                                     (symbol-name
@@ -3379,5 +3418,3 @@ initially undefined function references:~2%")
 
         (when core-file-name
           (write-initial-core-file core-file-name))))))
-
-