;;; a magic number used to identify our core files
(defconstant core-magic
- (logior (ash (char-code #\S) 24)
- (ash (char-code #\B) 16)
- (ash (char-code #\C) 8)
- (char-code #\L)))
+ (logior (ash (sb!xc:char-code #\S) 24)
+ (ash (sb!xc:char-code #\B) 16)
+ (ash (sb!xc:char-code #\C) 8)
+ (sb!xc:char-code #\L)))
;;; the current version of SBCL core files
;;;
bigvec)
\f
;;;; looking up bytes and multi-byte values in a BIGVEC (considering
-;;;; it as an image of machine memory)
+;;;; it as an image of machine memory on the cross-compilation target)
;;; BVREF-32 and friends. These are like SAP-REF-n, except that
;;; instead of a SAP we use a BIGVEC.
(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)))
type)))
(defun make-character-descriptor (data)
- (make-other-immediate-descriptor data sb!vm:base-char-widetag))
+ (make-other-immediate-descriptor data sb!vm:character-widetag))
(defun descriptor-beyond (des offset type)
(let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
\f
;;;; copying simple objects into the cold core
-(defun string-to-core (string &optional (gspace *dynamic*))
+(defun base-string-to-core (string &optional (gspace *dynamic*))
#!+sb-doc
- "Copy string into the cold core and return a descriptor to it."
+ "Copy STRING (which must only contain STANDARD-CHARs) into the cold
+core and return a descriptor to it."
;; (Remember that the system convention for storage of strings leaves an
;; extra null byte at the end to aid in call-out to C.)
(let* ((length (length string))
(make-fixnum-descriptor length))
(dotimes (i length)
(setf (bvref bytes (+ offset i))
- ;; KLUDGE: There's no guarantee that the character
- ;; encoding here will be the same as the character
- ;; encoding on the target machine, so using CHAR-CODE as
- ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
- ;; (To make this more portable, perhaps we could use
- ;; indices into the sequence which is used to test whether
- ;; a character is a STANDARD-CHAR?) -- WHN 19990817
- (char-code (aref string i))))
+ (sb!xc:char-code (aref string i))))
(setf (bvref bytes (+ offset length))
0) ; null string-termination character for C
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)
(make-fixnum-descriptor 0))
(write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
(write-wordindexed symbol sb!vm:symbol-name-slot
- (string-to-core name *dynamic*))
+ (base-string-to-core name *dynamic*))
(write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
symbol))
;;; 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
;; because that's the way CMU CL did it; I'm
;; not sure whether there's an underlying
;; reason. -- WHN 1990826
- (string-to-core "NIL" *dynamic*))
+ (base-string-to-core "NIL" *dynamic*))
(write-wordindexed des
(+ 1 sb!vm:symbol-package-slot)
result)
(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))
(let* ((cold-package (car cold-package-symbols-entry))
(symbols (cdr cold-package-symbols-entry))
(shadows (package-shadowing-symbols cold-package))
- (documentation (string-to-core (documentation cold-package t)))
+ (documentation (base-string-to-core (documentation cold-package t)))
(internal *nil-descriptor*)
(external *nil-descriptor*)
(imported-internal *nil-descriptor*)
(res *nil-descriptor*))
(dolist (u (package-use-list pkg))
(when (assoc u *cold-package-symbols*)
- (cold-push (string-to-core (package-name u)) use)))
+ (cold-push (base-string-to-core (package-name u)) use)))
(let* ((pkg-name (package-name pkg))
;; Make the package nickname lists for the standard packages
;; be the minimum specified by ANSI, regardless of what value
(t
(package-nicknames pkg)))))
(dolist (warm-nickname warm-nicknames)
- (cold-push (string-to-core warm-nickname) cold-nicknames)))
+ (cold-push (base-string-to-core warm-nickname) cold-nicknames)))
(cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
0.8))
(cold-push use res)
(cold-push (cold-intern :use) res)
- (cold-push (string-to-core (package-name pkg)) res)
+ (cold-push (base-string-to-core (package-name pkg)) res)
res))
\f
;;;; functions and fdefinition objects
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 ()
(defun foreign-symbols-to-core ()
(let ((result *nil-descriptor*))
(maphash (lambda (symbol value)
- (cold-push (cold-cons (string-to-core symbol)
+ (cold-push (cold-cons (base-string-to-core symbol)
(number-to-core value))
result))
*cold-foreign-symbol-table*)
(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"
+ time length was ~S and current length is ~S"
name
length
old-length))
(unless (equal inherits-list old-inherits-list)
(error "cold loading a reference to class ~S when the compile~%~
- time inherits were ~S~%~
- and current inherits are ~S"
+ time inherits were ~S~%~
+ and current inherits are ~S"
name
inherits-list
old-inherits-list))
(unless (= depthoid old-depthoid)
(error "cold loading a reference to class ~S when the compile~%~
- time inheritance depthoid was ~S and current inheritance~%~
- depthoid is ~S"
+ time inheritance depthoid was ~S and current inheritance~%~
+ 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
\f
;;;; cold fops for loading vectors
-(clone-cold-fop (fop-string)
- (fop-small-string)
+(clone-cold-fop (fop-base-string)
+ (fop-small-base-string)
(let* ((len (clone-arg))
(string (make-string len)))
(read-string-as-bytes *fasl-input-stream* string)
- (string-to-core 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)
;; 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
(do-cold-fixup code-object offset value kind))
code-object))
+#!+linkage-table
(define-cold-fop (fop-foreign-dataref-fixup)
(let* ((kind (pop-stack))
(code-object (pop-stack))
(format t "/*~%")
(dolist (line
'("This is a machine-generated file. Please do not edit it by hand."
+ "(As of sbcl-0.8.14, it came from WRITE-CONFIG-H in genesis.lisp.)"
""
"This file contains low-level information about the"
"internals of a particular version and configuration"
(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
;; (We write each character as a word in order to avoid
;; having to think about word alignment issues in the
;; sbcl-0.7.8 version of coreparse.c.)
- (write-word (char-code char))))
+ (write-word (sb!xc:char-code char))))
;; Write the New Directory entry header.
(write-word new-directory-core-entry-type-code)
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