1 ;;; This file contains the MIPS specific runtime stuff.
6 (define-alien-type os-context-t
(struct os-context-t-struct
))
7 (define-alien-type os-context-register-t unsigned-long-long
)
10 ;;;; MACHINE-TYPE and MACHINE-VERSION
12 (defun machine-type ()
13 "Returns a string describing the type of the local machine."
16 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
17 (defun get-machine-version ()
18 #!+little-endian
"little-endian"
19 #!-little-endian
"big-endian")
22 ;;;; FIXUP-CODE-OBJECT
24 (defun fixup-code-object (code offset value kind
)
25 (declare (type index offset
))
26 (unless (zerop (rem offset n-word-bytes
))
27 (error "Unaligned instruction? offset=#x~X." offset
))
29 (let ((sap (truly-the system-area-pointer
30 (%primitive sb
!c
::code-instructions code
))))
33 (aver (zerop (ash value -
28)))
34 (setf (ldb (byte 26 0) (sap-ref-32 sap offset
))
37 (setf (ldb (byte 16 0) (sap-ref-32 sap offset
))
38 (ash (1+ (ash value -
15)) -
1)))
40 (setf (ldb (byte 16 0) (sap-ref-32 sap offset
))
41 (ldb (byte 16 0) value
)))))))
44 (define-alien-routine ("os_context_pc_addr" context-pc-addr
)
45 (* os-context-register-t
)
46 (context (* os-context-t
) :in
))
48 (defun context-pc (context)
49 (declare (type (alien (* os-context-t
)) context
))
50 (int-sap (deref (context-pc-addr context
))))
52 (define-alien-routine ("os_context_register_addr" context-register-addr
)
53 (* os-context-register-t
)
54 (context (* os-context-t
) :in
)
57 (define-alien-routine ("os_context_bd_cause" context-bd-cause-int
)
59 (context (* os-context-t
) :in
))
61 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
62 ;;; (Are they used in anything time-critical, or just the debugger?)
63 (defun context-register (context index
)
64 (declare (type (alien (* os-context-t
)) context
))
65 (let ((addr (context-register-addr context index
)))
66 (declare (type (alien (* os-context-register-t
)) addr
))
69 (defun %set-context-register
(context index new
)
70 (declare (type (alien (* os-context-t
)) context
))
71 (let ((addr (context-register-addr context index
)))
72 (declare (type (alien (* os-context-register-t
)) addr
))
73 (setf (deref addr
) new
)))
75 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
76 ;;; register. FORMAT is the type of float to return.
78 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
79 ;;; long is another question. This stuff still needs testing.
80 (define-alien-routine ("os_context_fpregister_addr" context-float-register-addr
)
81 (* os-context-register-t
)
82 (context (* os-context-t
) :in
)
85 (defun context-float-register (context index format
)
86 (declare (type (alien (* os-context-t
)) context
))
87 (let ((addr (context-float-register-addr context index
)))
88 (declare (type (alien (* os-context-register-t
)) addr
))
89 (coerce (deref addr
) format
)))
91 (defun %set-context-float-register
(context index format new
)
92 (declare (type (alien (* os-context-t
)) context
))
93 (let ((addr (context-float-register-addr context index
)))
94 (declare (type (alien (* os-context-register-t
)) addr
))
95 (setf (deref addr
) (coerce new format
))))
98 ("arch_get_fp_control" floating-point-modes
) unsigned-int
)
100 (define-alien-routine
101 ("arch_set_fp_control" %floating-point-modes-setter
) void
(fp unsigned-int
:in
))
103 (defun (setf floating-point-modes
) (val) (%floating-point-modes-setter val
))
105 ;;; Given a signal context, return the floating point modes word in
106 ;;; the same format as returned by FLOATING-POINT-MODES.
107 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
109 (context (* os-context-t
) :in
))
111 ;;;; Internal-error-arguments.
113 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
115 ;;; Given the sigcontext, extract the internal error arguments from the
116 ;;; instruction stream. This is e.g.
117 ;;; 4 23 254 206 1 0 0 0
118 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
119 ;;; length data (everything is an octet)
121 (defun internal-error-args (context)
122 (declare (type (alien (* os-context-t
)) context
))
123 (/show0
"entering INTERNAL-ERROR-ARGS, CONTEXT=..")
125 (let ((pc (context-pc context
))
126 (cause (context-bd-cause-int context
)))
127 (declare (type system-area-pointer pc
))
128 (multiple-value-bind (error-number length sc-offsets
)
129 ;; KLUDGE: This exposure of the branch delay mechanism hurts.
130 (snarf-error-junk pc
(if (logbitp 31 cause
) 8 4))
131 (declare (ignore length
))
132 (values error-number sc-offsets
))))