1 ;;;; SPARC-specific runtime 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.
15 ;;; See x86-vm.lisp for a description of this.
16 (define-alien-type os-context-t
(struct os-context-t-struct
))
20 ;;;; MACHINE-TYPE and MACHINE-VERSION
22 (defun machine-type ()
23 "Returns a string describing the type of the local machine."
26 (defun machine-version ()
27 "Returns a string describing the version of the local machine."
31 (defun fixup-code-object (code offset fixup kind
)
32 (declare (type index offset
))
33 (unless (zerop (rem offset n-word-bytes
))
34 (error "Unaligned instruction? offset=#x~X." offset
))
36 (let ((sap (truly-the system-area-pointer
37 (%primitive sb
!kernel
::code-instructions code
))))
40 (error "Can't deal with CALL fixups, yet."))
42 (setf (ldb (byte 22 0) (sap-ref-32 sap offset
))
43 (ldb (byte 22 10) fixup
)))
45 (setf (ldb (byte 10 0) (sap-ref-32 sap offset
))
46 (ldb (byte 10 0) fixup
)))))))
49 ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp.
51 ;;;; See also x86-vm for commentary on signed vs unsigned.
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 (deref (context-pc-addr context
))))
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
))
76 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
77 ;;; register. FORMAT is the type of float to return.
79 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
80 ;;; long is another question. This stuff still needs testing.
82 (define-alien-routine ("os_context_float_register_addr" context-float-register-addr
)
84 (context (* os-context-t
))
87 (defun context-float-register (context index format
)
88 (declare (type (alien (* os-context-t
)) context
))
89 (coerce (deref (context-float-register-addr context index
)) format
))
91 (defun %set-context-float-register
(context index format new
)
92 (declare (type (alien (* os-context-t
)) context
))
93 (setf (deref (context-float-register-addr context index
))
96 ;;; Given a signal context, return the floating point modes word in
97 ;;; the same format as returned by FLOATING-POINT-MODES.
99 ;;; Under SunOS, we have a straightforward implementation in C:
101 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
102 (sb!alien
:unsigned
32)
103 (context (* os-context-t
)))
105 ;;; Under Linux, we have to contend with utterly broken signal handling.
107 (defun context-floating-point-modes (context)
108 (warn "stub CONTEXT-FLOATING-POINT-MODES")
111 ;;;; INTERNAL-ERROR-ARGS.
113 ;;; Given a (POSIX) signal context, extract the internal error
114 ;;; arguments from the instruction stream. This is e.g.
115 ;;; 4 23 254 240 2 0 0 0
116 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
117 ;;; length data (everything is an octet)
119 (defun internal-error-args (context)
120 (declare (type (alien (* os-context-t
)) context
))
121 (sb!int
::/show0
"entering INTERNAL-ERROR-ARGS")
122 (let* ((pc (context-pc context
))
123 (bad-inst (sap-ref-32 pc
0))
124 (op (ldb (byte 2 30) bad-inst
))
125 (op2 (ldb (byte 3 22) bad-inst
))
126 (op3 (ldb (byte 6 19) bad-inst
)))
127 (declare (type system-area-pointer pc
))
128 (cond ((and (= op
#b00
) (= op2
#b000
))
129 (args-for-unimp-inst context
))
130 ((and (= op
#b10
) (= (ldb (byte 4 2) op3
) #b1000
))
131 (args-for-tagged-add-inst context bad-inst
))
132 ((and (= op
#b10
) (= op3
#b111010
))
133 (args-for-tcc-inst bad-inst
))
135 (values #.
(error-number-or-lose 'unknown-error
) nil
)))))
137 (defun args-for-unimp-inst (context)
138 (declare (type (alien (* os-context-t
)) context
))
139 (let* ((pc (context-pc context
))
140 (length (sap-ref-8 pc
4))
141 (vector (make-array length
:element-type
'(unsigned-byte 8))))
142 (declare (type system-area-pointer pc
)
143 (type (unsigned-byte 8) length
)
144 (type (simple-array (unsigned-byte 8) (*)) vector
))
145 (copy-from-system-area pc
(* n-byte-bits
5)
146 vector
(* n-word-bits
148 (* length n-byte-bits
))
150 (error-number (sb!c
:read-var-integer vector index
)))
151 (collect ((sc-offsets))
153 (when (>= index length
)
155 (sc-offsets (sb!c
:read-var-integer vector index
)))
156 (values error-number
(sc-offsets))))))
158 (defun args-for-tagged-add-inst (context bad-inst
)
159 (declare (type (alien (* os-context-t
)) context
))
160 (let* ((rs1 (ldb (byte 5 14) bad-inst
))
161 (op1 (sb!kernel
:make-lisp-obj
(context-register context rs1
))))
163 (if (zerop (ldb (byte 1 13) bad-inst
))
164 (let* ((rs2 (ldb (byte 5 0) bad-inst
))
165 (op2 (sb!kernel
:make-lisp-obj
(context-register context rs2
))))
167 (values #.
(error-number-or-lose 'unknown-error
) nil
)
168 (values #.
(error-number-or-lose 'object-not-fixnum-error
)
169 (list (sb!c
::make-sc-offset
170 descriptor-reg-sc-number
172 (values #.
(error-number-or-lose 'unknown-error
) nil
))
173 (values #.
(error-number-or-lose 'object-not-fixnum-error
)
174 (list (sb!c
::make-sc-offset descriptor-reg-sc-number
177 (defun args-for-tcc-inst (bad-inst)
178 (let* ((trap-number (ldb (byte 8 0) bad-inst
))
179 (reg (ldb (byte 5 8) bad-inst
)))
180 (values (case trap-number
181 (#.object-not-list-trap
182 #.
(error-number-or-lose 'object-not-list-error
))
183 (#.object-not-instance-trap
184 #.
(error-number-or-lose 'object-not-instance-error
))
186 #.
(error-number-or-lose 'unknown-error
)))
187 (list (sb!c
::make-sc-offset descriptor-reg-sc-number reg
)))))