(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)
(maybe-record-with-translated-name '("-SIZE") 6)
(maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES") 7 :large t)
(maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
- (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9))))))
+ (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9)
+ (maybe-record-with-translated-name '("-GENERATION+") 10))))))
;; KLUDGE: these constants are sort of important, but there's no
;; pleasing way to inform the code above about them. So we fake
;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
(unless (eq nil (car current-error))
(format t "#define ~A ~D~%"
(c-symbol-name (car current-error))
- i)))))
+ i))))
+ (format t "#define INTERNAL_ERROR_NAMES \\~%~{~S~#[~:;, \\~%~]~}~%"
+ (map 'list #'cdr internal-errors)))
(terpri)
;; I'm not really sure why this is in SB!C, since it seems
(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
(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
(when core-file-name
(write-initial-core-file core-file-name))))))
-
-