X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Falpha-vm.lisp;h=343e746baf483c3b521b7ae58afbfca28883879c;hb=22b819c0cd0ca0ea5be52ba280b9e9e0b8e86210;hp=e6aad8dfc1a5dc6e1ba80336c870331308e79075;hpb=545fa4548b327804cf78afe38a2ecd94ced86162;p=sbcl.git diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index e6aad8d..343e746 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -15,7 +15,7 @@ (defvar *bits-per-word* 64) ;;; See x86-vm.lisp for a description of this. -(def-alien-type os-context-t (struct os-context-t-struct)) +(define-alien-type os-context-t (struct os-context-t-struct)) ;;;; MACHINE-TYPE and MACHINE-VERSION @@ -27,17 +27,18 @@ "Alpha") (defun fixup-code-object (code offset value kind) - (unless (zerop (rem offset word-bytes)) + (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)))) + (%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))))) + (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)) @@ -57,7 +58,7 @@ (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 +;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then ;;;; hacked for types. ;;;; ;;;; KLUDGE: The alpha has 64-bit registers, so these potentially @@ -71,14 +72,14 @@ ;;;; ;;;; See also x86-vm for commentary on signed vs unsigned. -(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long) +(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long) (context (* os-context-t))) (defun context-pc (context) (declare (type (alien (* os-context-t)) context)) (int-sap (deref (context-pc-addr context)))) -(def-alien-routine ("os_context_register_addr" context-register-addr) +(define-alien-routine ("os_context_register_addr" context-register-addr) (* unsigned-long) (context (* os-context-t)) (index int)) @@ -101,7 +102,8 @@ ;;; FIXME: Whether COERCE actually knows how to make a float out of a ;;; long is another question. This stuff still needs testing. -(def-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)) @@ -113,29 +115,31 @@ (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. @@ -145,7 +149,7 @@ ;;; (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)) @@ -155,32 +159,15 @@ (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 (* sb!vm:byte-bits 5) - vector (* sb!vm:n-word-bits - sb!vm:vector-data-offset) - (* length sb!vm:byte-bits)) + (copy-from-system-area pc (* n-byte-bits 5) + vector (* n-word-bits vector-data-offset) + (* length n-byte-bits)) (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) +