X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsparc-vm.lisp;h=22930ed342cb3ce4a15bcbf0bff746afa6b57ed0;hb=cd1b14acf6f548b28b8a14e554d779f0473122ec;hp=c7f39f240a4d8f3f7b91e329412c90e763b68fa6;hpb=68fd2d2dd6f265669a8957accd8a33e62786a97e;p=sbcl.git diff --git a/src/code/sparc-vm.lisp b/src/code/sparc-vm.lisp index c7f39f2..22930ed 100644 --- a/src/code/sparc-vm.lisp +++ b/src/code/sparc-vm.lisp @@ -9,41 +9,31 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!VM") - - ;;; See x86-vm.lisp for a description of this. (define-alien-type os-context-t (struct os-context-t-struct)) - - -;;;; MACHINE-TYPE and MACHINE-VERSION +;;;; MACHINE-TYPE (defun machine-type () "Returns a string describing the type of the local machine." "SPARC") - -(defun machine-version () - "Returns a string describing the version of the local machine." - "SPARC") - (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) (unless (zerop (rem offset n-word-bytes)) (error "Unaligned instruction? offset=#x~X." offset)) (sb!sys:without-gcing - (let ((sap (truly-the system-area-pointer - (%primitive sb!kernel::code-instructions code)))) + (let ((sap (%primitive sb!kernel::code-instructions code))) (ecase kind (:call - (error "Can't deal with CALL fixups, yet.")) + (error "Can't deal with CALL fixups, yet.")) (:sethi - (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) - (ldb (byte 22 10) fixup))) + (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) + (ldb (byte 22 10) fixup))) (:add - (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) - (ldb (byte 10 0) fixup))))))) + (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) + (ldb (byte 10 0) fixup))))))) ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp. @@ -95,30 +85,25 @@ ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. + +;;; Under SunOS, we have a straightforward implementation in C: +#!+sunos +(define-alien-routine ("os_context_fp_control" context-floating-point-modes) + (sb!alien:unsigned 32) + (context (* os-context-t))) + +;;; Under Linux, we have to contend with utterly broken signal handling. +#!+linux (defun context-floating-point-modes (context) - ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for - ;; POSIXness and (at the Lisp level) opaque signal contexts, - ;; this is stubified. It needs to be rewritten as an - ;; alien function. + (declare (ignore context)) (warn "stub CONTEXT-FLOATING-POINT-MODES") - ;; old code for Linux: - #+nil - (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw)) - (sw (slot (deref (slot context 'fpstate) 0) 'sw))) - ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw) - ;; NOT TESTED -- Clear sticky bits to clear interrupt condition. - (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f)) - ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw)) - ;; Simulate floating-point-modes VOP. - (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))) - 0) ;;;; INTERNAL-ERROR-ARGS. ;;; Given a (POSIX) signal context, extract the internal error ;;; arguments from the instruction stream. This is e.g. -;;; 4 23 254 240 2 0 0 0 +;;; 4 23 254 240 2 0 0 0 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~ ;;; length data (everything is an octet) ;;; (pc) @@ -126,76 +111,66 @@ (declare (type (alien (* os-context-t)) context)) (sb!int::/show0 "entering INTERNAL-ERROR-ARGS") (let* ((pc (context-pc context)) - (bad-inst (sap-ref-32 pc 0)) - (op (ldb (byte 2 30) bad-inst)) - (op2 (ldb (byte 3 22) bad-inst)) - (op3 (ldb (byte 6 19) bad-inst))) + (bad-inst (sap-ref-32 pc 0)) + (op (ldb (byte 2 30) bad-inst)) + (op2 (ldb (byte 3 22) bad-inst)) + (op3 (ldb (byte 6 19) bad-inst))) (declare (type system-area-pointer pc)) (cond ((and (= op #b00) (= op2 #b000)) - (args-for-unimp-inst context)) - ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000)) - (args-for-tagged-add-inst context bad-inst)) - ((and (= op #b10) (= op3 #b111010)) - (args-for-tcc-inst bad-inst)) - (t - (values #.(error-number-or-lose 'unknown-error) nil))))) + (args-for-unimp-inst context)) + ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000)) + (args-for-tagged-add-inst context bad-inst)) + ((and (= op #b10) (= op3 #b111010)) + (args-for-tcc-inst bad-inst)) + (t + (values #.(error-number-or-lose 'unknown-error) nil))))) (defun args-for-unimp-inst (context) (declare (type (alien (* os-context-t)) context)) (let* ((pc (context-pc context)) - (length (sap-ref-8 pc 4)) - (vector (make-array length :element-type '(unsigned-byte 8)))) + (length (sap-ref-8 pc 4)) + (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (type system-area-pointer pc) - (type (unsigned-byte 8) length) - (type (simple-array (unsigned-byte 8) (*)) vector)) - (copy-from-system-area pc (* n-byte-bits 5) - vector (* n-word-bits - vector-data-offset) - (* length n-byte-bits)) + (type (unsigned-byte 8) length) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (copy-ub8-from-system-area pc 5 vector 0 length) (let* ((index 0) - (error-number (sb!c::read-var-integer vector index))) + (error-number (sb!c:read-var-integer vector index))) (collect ((sc-offsets)) - (loop - (when (>= index length) - (return)) - (sc-offsets (sb!c::read-var-integer vector index))) - (values error-number (sc-offsets)))))) + (loop + (when (>= index length) + (return)) + (sc-offsets (sb!c:read-var-integer vector index))) + (values error-number (sc-offsets)))))) (defun args-for-tagged-add-inst (context bad-inst) (declare (type (alien (* os-context-t)) context)) (let* ((rs1 (ldb (byte 5 14) bad-inst)) - (op1 (sb!kernel:make-lisp-obj (context-register context rs1)))) + (op1 (sb!kernel:make-lisp-obj (context-register context rs1)))) (if (fixnump op1) - (if (zerop (ldb (byte 1 13) bad-inst)) - (let* ((rs2 (ldb (byte 5 0) bad-inst)) - (op2 (sb!kernel:make-lisp-obj (context-register context rs2)))) - (if (fixnump op2) - (values #.(error-number-or-lose 'unknown-error) nil) - (values #.(error-number-or-lose 'object-not-fixnum-error) - (list (sb!c::make-sc-offset - descriptor-reg-sc-number - rs2))))) - (values #.(error-number-or-lose 'unknown-error) nil)) - (values #.(error-number-or-lose 'object-not-fixnum-error) - (list (sb!c::make-sc-offset descriptor-reg-sc-number - rs1)))))) + (if (zerop (ldb (byte 1 13) bad-inst)) + (let* ((rs2 (ldb (byte 5 0) bad-inst)) + (op2 (sb!kernel:make-lisp-obj (context-register context rs2)))) + (if (fixnump op2) + (values #.(error-number-or-lose 'unknown-error) nil) + (values #.(error-number-or-lose 'object-not-fixnum-error) + (list (sb!c::make-sc-offset + descriptor-reg-sc-number + rs2))))) + (values #.(error-number-or-lose 'unknown-error) nil)) + (values #.(error-number-or-lose 'object-not-fixnum-error) + (list (sb!c::make-sc-offset descriptor-reg-sc-number + rs1)))))) (defun args-for-tcc-inst (bad-inst) (let* ((trap-number (ldb (byte 8 0) bad-inst)) - (reg (ldb (byte 5 8) bad-inst))) + (reg (ldb (byte 5 8) bad-inst))) (values (case trap-number - (#.object-not-list-trap - #.(error-number-or-lose 'object-not-list-error)) - (#.object-not-instance-trap - #.(error-number-or-lose 'object-not-instance-error)) - (t - #.(error-number-or-lose 'unknown-error))) - (list (sb!c::make-sc-offset descriptor-reg-sc-number reg))))) + (#.object-not-list-trap + #.(error-number-or-lose 'object-not-list-error)) + (#.object-not-instance-trap + #.(error-number-or-lose 'object-not-instance-error)) + (t + #.(error-number-or-lose 'unknown-error))) + (list (sb!c::make-sc-offset descriptor-reg-sc-number reg))))) - -;;; Do whatever is necessary to make the given code component -;;; executable. On the sparc, we don't need to do anything, because -;;; the i and d caches are unified. -(defun sanctify-for-execution (component) - (declare (ignore component)) - nil)