1 ;;;; Alpha-specific implementation stuff
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (defvar *number-of-signals* 64)
15 (defvar *bits-per-word* 64)
17 ;;; See x86-vm.lisp for a description of this.
18 (define-alien-type os-context-t (struct os-context-t-struct))
20 ;;;; MACHINE-TYPE and MACHINE-VERSION
22 (defun machine-type ()
23 "Return a string describing the type of the local machine."
26 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
27 (defun get-machine-version ()
30 (defun fixup-code-object (code offset value kind)
31 (unless (zerop (rem offset n-word-bytes))
32 (error "Unaligned instruction? offset=#x~X." offset))
34 (let ((sap (truly-the system-area-pointer
35 (%primitive code-instructions code))))
38 (assert (zerop (ldb (byte 2 0) value)))
40 (setf (sap-ref-16 sap offset)
41 (logior (sap-ref-16 sap offset)
42 (ldb (byte 14 0) (ash value -2)))))
44 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
45 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
46 (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
47 (setf (sap-ref-8 sap offset) (ldb (byte 8 48) value))
48 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 56) value))))
50 (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
51 (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
52 (setf (sap-ref-8 sap offset) (ldb (byte 8 32) value))
53 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 40) value))))
55 (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
56 (setf (sap-ref-8 sap offset) (ldb (byte 8 16) value))
57 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 24) value))))
59 (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value))
60 (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))))))
62 ;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then
63 ;;;; hacked for types.
65 ;;;; KLUDGE: The alpha has 64-bit registers, so these potentially
66 ;;;; return 64 bit numbers (which means bignums ... ew) We think that
67 ;;;; 99 times of 100 (i.e. unless something is badly wrong) we'll get
68 ;;;; answers that fit in 32 bits anyway. Which probably won't help us
69 ;;;; stop passing bignums around as the compiler can't prove they fit
70 ;;;; in 32 bits. But maybe the stuff it does on x86 to unbox 32-bit
71 ;;;; constants happens magically for 64-bit constants here. Just
72 ;;;; maybe. -- Dan Barlow, ca. 2001-05-05
74 ;;;; See also x86-vm for commentary on signed vs unsigned.
76 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
77 (context (* os-context-t)))
79 (defun context-pc (context)
80 (declare (type (alien (* os-context-t)) context))
81 (int-sap (deref (context-pc-addr context))))
83 (define-alien-routine ("os_context_register_addr" context-register-addr)
85 (context (* os-context-t))
88 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
89 ;;; (Are they used in anything time-critical, or just the debugger?)
90 (defun context-register (context index)
91 (declare (type (alien (* os-context-t)) context))
92 (deref (the (alien (* unsigned-long))
93 (context-register-addr context index))))
95 (defun %set-context-register (context index new)
96 (declare (type (alien (* os-context-t)) context))
97 (setf (deref (the (alien (* unsigned-long))
98 (context-register-addr context index)))
101 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
102 ;;; register. FORMAT is the type of float to return.
104 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
105 ;;; long is another question. This stuff still needs testing.
106 (define-alien-routine ("os_context_float_register_addr"
107 context-float-register-addr)
109 (context (* os-context-t))
111 (defun context-float-register (context index format)
112 (declare (type (alien (* os-context-t)) context))
113 (coerce (deref (context-float-register-addr context index)) format))
114 (defun %set-context-float-register (context index format new)
115 (declare (type (alien (* os-context-t)) context))
116 (setf (deref (context-float-register-addr context index))
117 (coerce new format)))
119 ;;; This sets the software fp_control word, which is not the same
120 ;;; thing as the hardware fpcr. We have to do this so that OS FPU
121 ;;; completion works properly
123 ;;; Note that this means we can't set rounding modes; we'd have to do
124 ;;; that separately. That said, almost everybody seems to agree that
125 ;;; changing the rounding mode is rarely a good idea, because it upsets
126 ;;; libm functions. So adding that is not a priority. Sorry.
129 (define-alien-routine
130 ("arch_get_fp_control" floating-point-modes) (sb!alien:unsigned 64))
132 (define-alien-routine
133 ("arch_set_fp_control" %floating-point-modes-setter) void (fp (sb!alien:unsigned 64)))
135 (defun (setf floating-point-modes) (val) (%floating-point-modes-setter val))
137 ;;; Given a signal context, return the floating point modes word in
138 ;;; the same format as returned by FLOATING-POINT-MODES.
139 (define-alien-routine ("os_context_fp_control" context-floating-point-modes)
140 (sb!alien:unsigned 64) (context (* os-context-t)))
143 ;;;; INTERNAL-ERROR-ARGS
145 ;;; Given a (POSIX) signal context, extract the internal error
146 ;;; arguments from the instruction stream. This is e.g.
147 ;;; 4 23 254 240 2 0 0 0
148 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
149 ;;; length data (everything is an octet)
151 ;;; (example from undefined_tramp: "(gdb) x/40ub 0x10148" for yourself
153 (defun internal-error-args (context)
154 (declare (type (alien (* os-context-t)) context))
155 (let ((pc (context-pc context)))
156 (declare (type system-area-pointer pc))
157 ;; pc is a SAP pointing at - or actually, shortly after -
158 ;; the instruction that got us into this mess in the first place
159 (let* ((length (sap-ref-8 pc 4))
160 (vector (make-array length :element-type '(unsigned-byte 8))))
161 (declare (type (unsigned-byte 8) length)
162 (type (simple-array (unsigned-byte 8) (*)) vector))
163 (copy-from-system-area pc (* n-byte-bits 5)
164 vector (* n-word-bits vector-data-offset)
165 (* length n-byte-bits))
167 (error-number (sb!c:read-var-integer vector index)))
168 (collect ((sc-offsets))
170 (when (>= index length)
172 (sc-offsets (sb!c:read-var-integer vector index)))
173 (values error-number (sc-offsets)))))))