X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=9b059d44a43dd413e5eab2dd630afb2ca2313590;hb=095a47764e687fa76cf0e2803633d30c65c00f40;hp=6f1140ef8a03dbf965fbe6c40946265e686eb638;hpb=75b52379bdc2269961af6a1308eca63610f38ac3;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 6f1140e..9b059d4 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -34,10 +34,10 @@ ;;; 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 ;;; @@ -156,7 +156,7 @@ bigvec) ;;;; 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. @@ -444,7 +444,7 @@ 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) @@ -608,9 +608,10 @@ ;;;; 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)) @@ -626,14 +627,7 @@ (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)) @@ -669,6 +663,30 @@ (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 @@ -684,17 +702,8 @@ (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)) @@ -712,39 +721,10 @@ (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) @@ -815,7 +795,7 @@ (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)) @@ -1201,7 +1181,7 @@ ;; 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) @@ -1269,6 +1249,7 @@ (frob sub-gc) (frob internal-error) (frob sb!kernel::control-stack-exhausted-error) + (frob sb!kernel::undefined-alien-error) (frob sb!di::handle-breakpoint) (frob sb!di::handle-fun-end-breakpoint) (frob sb!thread::handle-thread-exit)) @@ -1286,7 +1267,7 @@ (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*) @@ -1366,7 +1347,7 @@ (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 @@ -1387,7 +1368,7 @@ (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)) @@ -1404,7 +1385,7 @@ (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)) ;;;; functions and fdefinition objects @@ -1857,7 +1838,7 @@ (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*) @@ -1998,21 +1979,21 @@ (depthoid (descriptor-fixnum depthoid-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))) @@ -2105,12 +2086,17 @@ ;;;; 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) @@ -2455,12 +2441,12 @@ ;; 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 @@ -2489,6 +2475,7 @@ (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)) @@ -2566,6 +2553,7 @@ (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" @@ -2987,7 +2975,7 @@ initially undefined function references:~2%") ;; (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) @@ -3104,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) @@ -3172,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")