(ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
(ash bits (- 1 sb!vm:n-lowtag-bits)))))
+(defun descriptor-word-sized-integer (des)
+ ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
+ ;; representation.
+ (let ((lowtag (descriptor-lowtag des)))
+ (if (or (= lowtag sb!vm:even-fixnum-lowtag)
+ (= lowtag sb!vm:odd-fixnum-lowtag))
+ (make-random-descriptor (descriptor-fixnum des))
+ (read-wordindexed des 1))))
+
;;; common idioms
(defun descriptor-bytes (des)
(gspace-bytes (descriptor-intuit-gspace des)))
(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 (1+ 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
+ ;; 64-bit platforms have immediate single-floats.
+ #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
+ (make-random-descriptor (logior (ash (single-float-bits x) 32)
+ sb!vm::single-float-widetag))
+ #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
(let ((des (allocate-unboxed-object *dynamic*
sb!vm:n-word-bits
(1- sb!vm:single-float-size)
(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))
(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)
;;; FIXME: This information should probably be pulled out of the
;;; cross-compiler's tables at genesis time instead of inserted by
;;; hand here as a bare numeric constant.
-(defconstant target-layout-length 16)
+(defconstant target-layout-length 17)
;;; Return a list of names created from the cold layout INHERITS data
;;; in X.
(descriptor-bits des)))))
(res))))
-(declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor)
+(declaim (ftype (function (symbol descriptor descriptor descriptor descriptor)
+ descriptor)
make-cold-layout))
-(defun make-cold-layout (name length inherits depthoid)
+(defun make-cold-layout (name length inherits depthoid nuntagged)
(let ((result (allocate-boxed-object *dynamic*
;; KLUDGE: Why 1+? -- WHN 19990901
(1+ target-layout-length)
(write-wordindexed result (+ base 3) depthoid)
(write-wordindexed result (+ base 4) length)
(write-wordindexed result (+ base 5) *nil-descriptor*) ; info
- (write-wordindexed result (+ base 6) *nil-descriptor*)) ; pure
+ (write-wordindexed result (+ base 6) *nil-descriptor*) ; pure
+ (write-wordindexed result (+ base 7) nuntagged))
(setf (gethash name *cold-layouts*)
(list result
name
(descriptor-fixnum length)
(listify-cold-inherits inherits)
- (descriptor-fixnum depthoid)))
+ (descriptor-fixnum depthoid)
+ (descriptor-fixnum nuntagged)))
(setf (gethash (descriptor-bits result) *cold-layout-names*) name)
result))
(number-to-core target-layout-length)
(vector-in-core)
;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
- (number-to-core 4)))
+ (number-to-core 4)
+ ;; no raw slots in LAYOUT:
+ (number-to-core 0)))
(write-wordindexed *layout-layout*
sb!vm:instance-slots-offset
*layout-layout*)
(make-cold-layout 't
(number-to-core 0)
(vector-in-core)
+ (number-to-core 0)
(number-to-core 0)))
(i-layout
(make-cold-layout 'instance
(number-to-core 0)
(vector-in-core t-layout)
- (number-to-core 1)))
+ (number-to-core 1)
+ (number-to-core 0)))
(so-layout
(make-cold-layout 'structure-object
(number-to-core 1)
(vector-in-core t-layout i-layout)
- (number-to-core 2)))
+ (number-to-core 2)
+ (number-to-core 0)))
(bso-layout
(make-cold-layout 'structure!object
(number-to-core 1)
(vector-in-core t-layout i-layout so-layout)
- (number-to-core 3)))
+ (number-to-core 3)
+ (number-to-core 0)))
(layout-inherits (vector-in-core t-layout
i-layout
so-layout
(frob sub-gc)
(frob internal-error)
(frob sb!kernel::control-stack-exhausted-error)
+ (frob sb!kernel::undefined-alien-variable-error)
+ (frob sb!kernel::undefined-alien-function-error)
+ (frob sb!kernel::memory-fault-error)
(frob sb!di::handle-breakpoint)
- (frob sb!di::handle-fun-end-breakpoint)
- (frob sb!thread::handle-thread-exit))
+ (frob sb!di::handle-fun-end-breakpoint))
(cold-set 'sb!vm::*current-catch-block* (make-fixnum-descriptor 0))
(cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))
sb!vm:fdefn-raw-addr-slot
(make-random-descriptor
(cold-foreign-symbol-address-as-integer
- (sb!vm:extern-alien-name "undefined_tramp")))))
+ "undefined_tramp"))))
fdefn))))
;;; Handle the at-cold-init-time, fset-for-static-linkage operation
(/show0 "/static-fset (closure)")
(make-random-descriptor
(cold-foreign-symbol-address-as-integer
- (sb!vm:extern-alien-name "closure_tramp"))))))
+ "closure_tramp")))))
fdefn))
(defun initialize-static-fns ()
(let* ((size (clone-arg))
(result (allocate-boxed-object *dynamic*
(1+ size)
- sb!vm:instance-pointer-lowtag)))
+ sb!vm:instance-pointer-lowtag))
+ (layout (pop-stack))
+ (nuntagged
+ (descriptor-fixnum
+ (read-wordindexed layout (+ sb!vm:instance-slots-offset 16))))
+ (ntagged (- size nuntagged)))
(write-memory result (make-other-immediate-descriptor
size sb!vm:instance-header-widetag))
- (do ((index (1- size) (1- index)))
- ((minusp index))
+ (write-wordindexed result sb!vm:instance-slots-offset layout)
+ (do ((index 1 (1+ index)))
+ ((eql index size))
(declare (fixnum index))
(write-wordindexed result
(+ index sb!vm:instance-slots-offset)
- (pop-stack)))
+ (if (>= index ntagged)
+ (descriptor-word-sized-integer (pop-stack))
+ (pop-stack))))
result))
(define-cold-fop (fop-layout)
- (let* ((length-des (pop-stack))
+ (let* ((nuntagged-des (pop-stack))
+ (length-des (pop-stack))
(depthoid-des (pop-stack))
(cold-inherits (pop-stack))
(name (pop-stack))
old-name
old-length
old-inherits-list
- old-depthoid)
+ old-depthoid
+ old-nuntagged)
old
(declare (type descriptor old-layout-descriptor))
- (declare (type index old-length))
+ (declare (type index old-length old-nuntagged))
(declare (type fixnum old-depthoid))
(declare (type list old-inherits-list))
(aver (eq name old-name))
(let ((length (descriptor-fixnum length-des))
(inherits-list (listify-cold-inherits cold-inherits))
- (depthoid (descriptor-fixnum depthoid-des)))
+ (depthoid (descriptor-fixnum depthoid-des))
+ (nuntagged (descriptor-fixnum nuntagged-des)))
(unless (= length old-length)
(error "cold loading a reference to class ~S when the compile~%~
time length was ~S and current length is ~S"
depthoid is ~S"
name
depthoid
- old-depthoid)))
+ old-depthoid))
+ (unless (= nuntagged old-nuntagged)
+ (error "cold loading a reference to class ~S when the compile~%~
+ time number of untagged slots was ~S and is currently ~S"
+ name
+ nuntagged
+ old-nuntagged)))
old-layout-descriptor)
;; Make a new definition from scratch.
- (make-cold-layout name length-des cold-inherits depthoid-des))))
+ (make-cold-layout name length-des cold-inherits depthoid-des
+ nuntagged-des))))
\f
;;;; cold fops for loading symbols
(read-string-as-bytes *fasl-input-stream* string)
(base-string-to-core string)))
+#!+sb-unicode
+(clone-cold-fop (fop-character-string)
+ (fop-small-character-string)
+ (bug "CHARACTER-STRING dumped by cross-compiler."))
+
(clone-cold-fop (fop-vector)
(fop-small-vector)
(let* ((size (clone-arg))
;; 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
(terpri)))
(format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
+(defun write-structure-object (dd)
+ (flet ((cstring (designator)
+ (substitute #\_ #\- (string-downcase (string designator)))))
+ (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+ (format t "struct ~A {~%" (cstring (dd-name dd)))
+ (format t " lispobj header;~%")
+ (format t " lispobj layout;~%")
+ (dolist (slot (dd-slots dd))
+ (when (eq t (dsd-raw-type slot))
+ (format t " lispobj ~A;~%" (cstring (dsd-name slot)))))
+ (unless (oddp (+ (dd-length dd) (dd-raw-length dd)))
+ (format t " long raw_slot_padding;~%"))
+ (dotimes (n (dd-raw-length dd))
+ (format t " long raw~D;~%" (- (dd-raw-length dd) n 1)))
+ (format t "};~2%")
+ (format t "#endif /* LANGUAGE_ASSEMBLY */~2%")))
+
(defun write-static-symbols ()
(dolist (symbol (cons nil sb!vm:*static-symbols*))
;; FIXME: It would be nice to use longer names than NIL and
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)
;; 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")
(format t "~&#include \"~A.h\"~%"
(string-downcase
(string (sb!vm:primitive-object-name obj)))))))
+ (dolist (class '(hash-table layout))
+ (out-to
+ (string-downcase (string class))
+ (write-structure-object
+ (sb!kernel:layout-info (sb!kernel:find-layout class)))))
(out-to "static-symbols" (write-static-symbols))
(when core-file-name
projects / sbcl.git / blobdiff