X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Falpha-vm.lisp;h=e8b4875a092e5fd23119f2150b847168a6b49b4b;hb=18dc0069cd514c976042766ab9a785c970fe1603;hp=44ec30e107dff25d89d860d7b7449b8cbd1fc7c3;hpb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;p=sbcl.git diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 44ec30e..e8b4875 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -10,53 +10,46 @@ ;;;; files for more information. (in-package "SB!VM") - -(defvar *number-of-signals* 64) -(defvar *bits-per-word* 64) ;;; 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 () "Return a string describing the type of the local machine." "Alpha") -(defun machine-version () - "Return a string describing the version of the local machine." - "Alpha") (defun fixup-code-object (code offset value kind) (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 code-instructions code))) (ecase kind (:jmp-hint - (assert (zerop (ldb (byte 2 0) value))) - #+nil - (setf (sap-ref-16 sap offset) - (logior (sap-ref-16 sap offset) - (ldb (byte 14 0) (ash value -2))))) + (aver (zerop (ldb (byte 2 0) value))) + #+nil + (setf (sap-ref-16 sap offset) + (logior (sap-ref-16 sap offset) + (ldb (byte 14 0) (ash value -2))))) (:bits-63-48 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) - (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value)) + (value (if (logbitp 47 value) (+ value (ash 1 48)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value)))) (:bits-47-32 - (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) - (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) + (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)) + (value (if (logbitp 31 value) (+ value (ash 1 32)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value)))) (:ldah - (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) - (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) + (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value)))) (:lda - (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) - (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) + (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) + (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) ;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then ;;;; hacked for types. @@ -89,21 +82,21 @@ (defun context-register (context index) (declare (type (alien (* os-context-t)) context)) (deref (the (alien (* unsigned-long)) - (context-register-addr context index)))) + (context-register-addr context index)))) (defun %set-context-register (context index new) (declare (type (alien (* os-context-t)) context)) (setf (deref (the (alien (* unsigned-long)) - (context-register-addr context index))) - new)) + (context-register-addr context index))) + new)) ;;; This is like CONTEXT-REGISTER, but returns the value of a float ;;; register. FORMAT is the type of float to return. ;;; FIXME: Whether COERCE actually knows how to make a float out of a ;;; long is another question. This stuff still needs testing. -(define-alien-routine ("os_context_fpregister_addr" - context-float-register-addr) +(define-alien-routine ("os_context_float_register_addr" + context-float-register-addr) (* long) (context (* os-context-t)) (index int)) @@ -115,39 +108,41 @@ (setf (deref (context-float-register-addr context index)) (coerce new format))) +;;; This sets the software fp_control word, which is not the same +;;; thing as the hardware fpcr. We have to do this so that OS FPU +;;; completion works properly + +;;; Note that this means we can't set rounding modes; we'd have to do +;;; that separately. That said, almost everybody seems to agree that +;;; changing the rounding mode is rarely a good idea, because it upsets +;;; libm functions. So adding that is not a priority. Sorry. +;;; -dan 2001.02.06 + +(define-alien-routine + ("arch_get_fp_control" floating-point-modes) (sb!alien:unsigned 64)) + +(define-alien-routine + ("arch_set_fp_control" %floating-point-modes-setter) void (fp (sb!alien:unsigned 64))) + +(defun (setf floating-point-modes) (val) (%floating-point-modes-setter val)) + ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. -(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. - (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) +(define-alien-routine ("os_context_fp_control" context-floating-point-modes) + (sb!alien:unsigned 64) (context (* os-context-t))) + -;;;; INTERNAL-ERROR-ARGUMENTS +;;;; 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) ;;; (example from undefined_tramp: "(gdb) x/40ub 0x10148" for yourself ;;; to replicate) -(defun internal-error-arguments (context) +(defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (let ((pc (context-pc context))) (declare (type system-area-pointer pc)) @@ -157,31 +152,13 @@ (vector (make-array length :element-type '(unsigned-byte 8)))) (declare (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)) + (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))) + (sc-offsets (sb!c:read-var-integer vector index))) (values error-number (sc-offsets))))))) - -;;; The loader uses this to convert alien names to the form they -;;; occure in the symbol table (for example, prepending an -;;; underscore). -(defun extern-alien-name (name) - (declare (type simple-base-string name)) - ;; On the Alpha we don't do anything. - name) - -;;;; Do whatever is necessary to make the given code component -;;;; executable. -;;;; -;;;; XXX do we really not have to flush caches or something here? I -;;;; need an architecture manual -(defun sanctify-for-execution (component) - (declare (ignore component)) - nil) +