3 (define-alien-type os-context-t
(struct os-context-t-struct
))
8 "Returns a string describing the type of the local machine."
11 ;;;; FIXUP-CODE-OBJECT
12 ;FIX-lav: unify code with genesis.lisp fixup
13 (defun fixup-code-object (code offset value kind
)
14 (unless (zerop (rem offset n-word-bytes
))
15 (error "Unaligned instruction? offset=#x~X." offset
))
17 (let* ((sap (%primitive code-instructions code
))
18 (inst (sap-ref-32 sap offset
)))
19 (setf (sap-ref-32 sap offset
)
22 (logior (mask-field (byte 18 14) value
)
24 (1+ (ash (ldb (byte 13 0) value
) 1))
25 (ash (ldb (byte 13 0) value
) 1))))
27 (logior (if (< value
0)
28 (1+ (ash (ldb (byte 10 0) value
) 1))
29 (ash (ldb (byte 11 0) value
) 1))
30 (mask-field (byte 18 14) inst
)))
32 (let ((low-bits (ldb (byte 11 0) value
)))
33 (aver (<= 0 low-bits
(1- (ash 1 4))))
34 (logior (ash (dpb (ldb (byte 4 0) value
)
36 (ldb (byte 1 4) value
)) 17)
37 (logand inst
#xffe0ffff
))))
39 (logior (ash (ldb (byte 5 13) value
) 16)
40 (ash (ldb (byte 2 18) value
) 14)
41 (ash (ldb (byte 2 11) value
) 12)
42 (ash (ldb (byte 11 20) value
) 1)
43 (ldb (byte 1 31) value
)
44 (logand inst
#xffe00000
)))
46 (let ((bits (ldb (byte 9 2) value
)))
47 (aver (zerop (ldb (byte 2 0) value
)))
49 (mask-field (byte 1 1) inst
)
50 (mask-field (byte 3 13) inst
)
51 (mask-field (byte 11 21) inst
)))))))))
53 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-int
)
54 (context (* os-context-t
)))
56 (defun context-pc (context)
57 (declare (type (alien (* os-context-t
)) context
))
58 (int-sap (logandc2 (deref (context-pc-addr context
)) 3)))
60 (define-alien-routine ("os_context_register_addr" context-register-addr
)
62 (context (* os-context-t
))
65 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
66 ;;; (Are they used in anything time-critical, or just the debugger?)
67 (defun context-register (context index
)
68 (declare (type (alien (* os-context-t
)) context
))
69 (deref (context-register-addr context index
)))
71 (defun %set-context-register
(context index new
)
72 (declare (type (alien (* os-context-t
)) context
))
73 (setf (deref (context-register-addr context index
))
78 (defun context-floating-point-modes (context)
79 (warn "stub CONTEXT-FLOATING-POINT-MODES")
82 ;;;; Internal-error-arguments.
84 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
86 ;;; Given the sigcontext, extract the internal error arguments from the
87 ;;; instruction stream.
89 (defun internal-error-args (context)
90 (declare (type (alien (* os-context-t
)) context
))
91 (let ((pc (context-pc context
)))
92 (declare (type system-area-pointer pc
))
93 (let* ((length (sap-ref-8 pc
4))
94 (vector (make-array length
:element-type
'(unsigned-byte 8))))
95 (declare (type (unsigned-byte 8) length
)
96 (type (simple-array (unsigned-byte 8) (*)) vector
))
97 (copy-ub8-from-system-area pc
5 vector
0 length
)
99 (error-number (sb!c
:read-var-integer vector index
)))
100 (collect ((sc-offsets))
102 (when (>= index length
)
104 (sc-offsets (sb!c
:read-var-integer vector index
)))
105 (values error-number
(sc-offsets)))))))