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 ;;; See x86-vm.lisp for a description of this.
15 (define-alien-type os-context-t
(struct os-context-t-struct
))
19 (defun machine-type ()
20 "Return a string describing the type of the local machine."
23 (defun fixup-code-object (code offset value kind
)
24 (unless (zerop (rem offset n-word-bytes
))
25 (error "Unaligned instruction? offset=#x~X." offset
))
27 (let ((sap (%primitive code-instructions code
)))
30 (aver (zerop (ldb (byte 2 0) value
)))
32 (setf (sap-ref-16 sap offset
)
33 (logior (sap-ref-16 sap offset
)
34 (ldb (byte 14 0) (ash value -
2)))))
36 (let* ((value (if (logbitp 15 value
) (+ value
(ash 1 16)) value
))
37 (value (if (logbitp 31 value
) (+ value
(ash 1 32)) value
))
38 (value (if (logbitp 47 value
) (+ value
(ash 1 48)) value
)))
39 (setf (sap-ref-8 sap offset
) (ldb (byte 8 48) value
))
40 (setf (sap-ref-8 sap
(1+ offset
)) (ldb (byte 8 56) value
))))
42 (let* ((value (if (logbitp 15 value
) (+ value
(ash 1 16)) value
))
43 (value (if (logbitp 31 value
) (+ value
(ash 1 32)) value
)))
44 (setf (sap-ref-8 sap offset
) (ldb (byte 8 32) value
))
45 (setf (sap-ref-8 sap
(1+ offset
)) (ldb (byte 8 40) value
))))
47 (let ((value (if (logbitp 15 value
) (+ value
(ash 1 16)) value
)))
48 (setf (sap-ref-8 sap offset
) (ldb (byte 8 16) value
))
49 (setf (sap-ref-8 sap
(1+ offset
)) (ldb (byte 8 24) value
))))
51 (setf (sap-ref-8 sap offset
) (ldb (byte 8 0) value
))
52 (setf (sap-ref-8 sap
(1+ offset
)) (ldb (byte 8 8) value
)))
54 (setf (sap-ref-32 sap offset
) value
))))))
56 ;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then
57 ;;;; hacked for types.
59 ;;;; KLUDGE: The alpha has 64-bit registers, so these potentially
60 ;;;; return 64 bit numbers (which means bignums ... ew) We think that
61 ;;;; 99 times of 100 (i.e. unless something is badly wrong) we'll get
62 ;;;; answers that fit in 32 bits anyway. Which probably won't help us
63 ;;;; stop passing bignums around as the compiler can't prove they fit
64 ;;;; in 32 bits. But maybe the stuff it does on x86 to unbox 32-bit
65 ;;;; constants happens magically for 64-bit constants here. Just
66 ;;;; maybe. -- Dan Barlow, ca. 2001-05-05
68 ;;;; See also x86-vm for commentary on signed vs unsigned.
70 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-long
)
71 (context (* os-context-t
)))
73 (defun context-pc (context)
74 (declare (type (alien (* os-context-t
)) context
))
75 (int-sap (deref (context-pc-addr context
))))
77 (define-alien-routine ("os_context_register_addr" context-register-addr
)
79 (context (* os-context-t
))
82 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
83 ;;; (Are they used in anything time-critical, or just the debugger?)
84 (defun context-register (context index
)
85 (declare (type (alien (* os-context-t
)) context
))
86 (deref (the (alien (* unsigned-long
))
87 (context-register-addr context index
))))
89 (defun %set-context-register
(context index new
)
90 (declare (type (alien (* os-context-t
)) context
))
91 (setf (deref (the (alien (* unsigned-long
))
92 (context-register-addr context index
)))
95 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
96 ;;; register. FORMAT is the type of float to return.
98 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
99 ;;; long is another question. This stuff still needs testing.
100 (define-alien-routine ("os_context_float_register_addr"
101 context-float-register-addr
)
103 (context (* os-context-t
))
105 (defun context-float-register (context index format
)
106 (declare (type (alien (* os-context-t
)) context
))
107 (coerce (deref (context-float-register-addr context index
)) format
))
108 (defun %set-context-float-register
(context index format new
)
109 (declare (type (alien (* os-context-t
)) context
))
110 (setf (deref (context-float-register-addr context index
))
111 (coerce new format
)))
113 ;;; This sets the software fp_control word, which is not the same
114 ;;; thing as the hardware fpcr. We have to do this so that OS FPU
115 ;;; completion works properly
117 ;;; Note that this means we can't set rounding modes; we'd have to do
118 ;;; that separately. That said, almost everybody seems to agree that
119 ;;; changing the rounding mode is rarely a good idea, because it upsets
120 ;;; libm functions. So adding that is not a priority. Sorry.
123 (define-alien-routine
124 ("arch_get_fp_control" floating-point-modes
) (unsigned 64))
126 (define-alien-routine
127 ("arch_set_fp_control" %floating-point-modes-setter
) void
(fp (unsigned 64)))
129 (defun (setf floating-point-modes
) (val) (%floating-point-modes-setter val
))
131 ;;; Given a signal context, return the floating point modes word in
132 ;;; the same format as returned by FLOATING-POINT-MODES.
133 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
134 (unsigned 64) (context (* os-context-t
)))
137 ;;;; INTERNAL-ERROR-ARGS
138 (defun internal-error-args (context)
139 (declare (type (alien (* os-context-t
)) context
))
140 (let* ((pc (context-pc context
))
141 (error-number (sap-ref-8 pc
4)))
142 (declare (type system-area-pointer pc
))
144 (sb!kernel
::decode-internal-error-args
(sap+ pc
5) error-number
))))