3 (define-alien-type os-context-t
(struct os-context-t-struct
))
5 ;;;; MACHINE-TYPE and MACHINE-VERSION
8 "Returns a string describing the type of the local machine."
11 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
12 (defun get-machine-version ()
15 ;;;; FIXUP-CODE-OBJECT
17 (defun fixup-code-object (code offset value kind
)
18 (unless (zerop (rem offset n-word-bytes
))
19 (error "Unaligned instruction? offset=#x~X." offset
))
21 (let* ((sap (%primitive sb
!kernel
::code-instructions code
))
22 (inst (sap-ref-32 sap offset
)))
23 (setf (sap-ref-32 sap offset
)
26 (logior (ash (ldb (byte 11 0) value
) 1)
27 (logand inst
#xffffc000
)))
29 (let ((low-bits (ldb (byte 11 0) value
)))
30 (aver (<= 0 low-bits
(1- (ash 1 4))))
31 (logior (ash low-bits
17)
32 (logand inst
#xffe0ffff
))))
34 (logior (ash (ldb (byte 5 13) value
) 16)
35 (ash (ldb (byte 2 18) value
) 14)
36 (ash (ldb (byte 2 11) value
) 12)
37 (ash (ldb (byte 11 20) value
) 1)
38 (ldb (byte 1 31) value
)
39 (logand inst
#xffe00000
)))
41 (let ((bits (ldb (byte 9 2) value
)))
42 (aver (zerop (ldb (byte 2 0) value
)))
44 (logand inst
#xffe0e002
)))))))))
46 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-int
)
47 (context (* os-context-t
)))
49 (defun context-pc (context)
50 (declare (type (alien (* os-context-t
)) context
))
51 (int-sap (logandc2 (deref (context-pc-addr context
)) 3)))
53 (define-alien-routine ("os_context_register_addr" context-register-addr
)
55 (context (* os-context-t
))
58 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
59 ;;; (Are they used in anything time-critical, or just the debugger?)
60 (defun context-register (context index
)
61 (declare (type (alien (* os-context-t
)) context
))
62 (deref (context-register-addr context index
)))
64 (defun %set-context-register
(context index new
)
65 (declare (type (alien (* os-context-t
)) context
))
66 (setf (deref (context-register-addr context index
))
71 (defun context-floating-point-modes (context)
72 (warn "stub CONTEXT-FLOATING-POINT-MODES")
75 ;;;; Internal-error-arguments.
77 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
79 ;;; Given the sigcontext, extract the internal error arguments from the
80 ;;; instruction stream.
82 (defun internal-error-args (context)
83 (declare (type (alien (* os-context-t
)) context
))
84 (let ((pc (context-pc context
)))
85 (declare (type system-area-pointer pc
))
86 (let* ((length (sap-ref-8 pc
4))
87 (vector (make-array length
:element-type
'(unsigned-byte 8))))
88 (declare (type (unsigned-byte 8) length
)
89 (type (simple-array (unsigned-byte 8) (*)) vector
))
90 (copy-ub8-from-system-area pc
5 vector
0 length
)
92 (error-number (sb!c
:read-var-integer vector index
)))
93 (collect ((sc-offsets))
95 (when (>= index length
)
97 (sc-offsets (sb!c
:read-var-integer vector index
)))
98 (values error-number
(sc-offsets)))))))