X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=ba452c3795d546dff59e7a94f967deb10e7368eb;hb=a2ff6543c79752bfe42578f794bda1c28167fd10;hp=fdfa8482bbef48ebd2c664503bdad811de837cfc;hpb=5e1fcdac979db9a6aebe69531229355def8c0f90;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index fdfa848..ba452c3 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -663,9 +663,38 @@ core and return a descriptor to it." (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) @@ -678,17 +707,8 @@ core and return a descriptor to it." (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)) @@ -706,39 +726,10 @@ core and return a descriptor to it." (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) @@ -1263,7 +1254,9 @@ core and return a descriptor to it." (frob sub-gc) (frob internal-error) (frob sb!kernel::control-stack-exhausted-error) - (frob sb!kernel::undefined-alien-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)) @@ -1481,7 +1474,7 @@ core and return a descriptor to it." 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 @@ -1508,7 +1501,7 @@ core and return a descriptor to it." (/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 () @@ -2455,12 +2448,12 @@ core and return a descriptor to it." ;; 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 @@ -3106,7 +3099,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) @@ -3174,7 +3167,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")