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
)
24 (logior (mask-field (byte 18 14) value
)
26 (1+ (ash (ldb (byte 13 0) value
) 1))
27 (ash (ldb (byte 13 0) value
) 1))))
29 (logior (if (< value
0)
30 (1+ (ash (ldb (byte 10 0) value
) 1))
31 (ash (ldb (byte 11 0) value
) 1))
32 (mask-field (byte 18 14) inst
)))
34 (let ((low-bits (ldb (byte 11 0) value
)))
35 (aver (<= 0 low-bits
(1- (ash 1 4))))
36 (logior (ash (dpb (ldb (byte 4 0) value
)
38 (ldb (byte 1 4) value
)) 17)
39 (logand inst
#xffe0ffff
))))
41 (logior (ash (ldb (byte 5 13) value
) 16)
42 (ash (ldb (byte 2 18) value
) 14)
43 (ash (ldb (byte 2 11) value
) 12)
44 (ash (ldb (byte 11 20) value
) 1)
45 (ldb (byte 1 31) value
)
46 (logand inst
#xffe00000
)))
48 (let ((bits (ldb (byte 9 2) value
)))
49 (aver (zerop (ldb (byte 2 0) value
)))
51 (mask-field (byte 1 1) inst
)
52 (mask-field (byte 3 13) inst
)
53 (mask-field (byte 11 21) inst
)))))))))
55 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-int
)
56 (context (* os-context-t
)))
58 (defun context-pc (context)
59 (declare (type (alien (* os-context-t
)) context
))
60 (int-sap (logandc2 (deref (context-pc-addr context
)) 3)))
62 (define-alien-routine ("os_context_register_addr" context-register-addr
)
64 (context (* os-context-t
))
67 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
68 ;;; (Are they used in anything time-critical, or just the debugger?)
69 (defun context-register (context index
)
70 (declare (type (alien (* os-context-t
)) context
))
71 (deref (context-register-addr context index
)))
73 (defun %set-context-register
(context index new
)
74 (declare (type (alien (* os-context-t
)) context
))
75 (setf (deref (context-register-addr context index
))
80 (defun context-floating-point-modes (context)
81 (declare (ignore context
))
82 (warn "stub CONTEXT-FLOATING-POINT-MODES")
85 ;;;; Internal-error-arguments.
87 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
89 ;;; Given the sigcontext, extract the internal error arguments from the
90 ;;; instruction stream.
92 (defun internal-error-args (context)
93 (declare (type (alien (* os-context-t
)) context
))
94 (let* ((pc (context-pc context
))
95 (error-number (sap-ref-8 pc
4)))
96 (declare (type system-area-pointer pc
))
98 (sb!kernel
::decode-internal-error-args
(sap+ pc
5) error-number
))))