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.
13 ;;; See x86-vm.lisp for a description of this.
14 (define-alien-type os-context-t
(struct os-context-t-struct
))
16 ;;;; MACHINE-TYPE and MACHINE-VERSION
18 (defun machine-type ()
19 "Returns a string describing the type of the local machine."
22 ;;; support for CL:MACHINE-VERSION defined OAOO elsewhere
23 (defun get-machine-version ()
26 (defun fixup-code-object (code offset fixup kind
)
27 (declare (type index offset
))
28 (unless (zerop (rem offset n-word-bytes
))
29 (error "Unaligned instruction? offset=#x~X." offset
))
31 (let ((sap (truly-the system-area-pointer
32 (%primitive sb
!kernel
::code-instructions code
))))
35 (error "Can't deal with CALL fixups, yet."))
37 (setf (ldb (byte 22 0) (sap-ref-32 sap offset
))
38 (ldb (byte 22 10) fixup
)))
40 (setf (ldb (byte 10 0) (sap-ref-32 sap offset
))
41 (ldb (byte 10 0) fixup
)))))))
44 ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp.
46 ;;;; See also x86-vm for commentary on signed vs unsigned.
48 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-int
)
49 (context (* os-context-t
)))
51 (defun context-pc (context)
52 (declare (type (alien (* os-context-t
)) context
))
53 (int-sap (deref (context-pc-addr context
))))
55 (define-alien-routine ("os_context_register_addr" context-register-addr
)
57 (context (* os-context-t
))
60 ;;; FIXME: Should this and CONTEXT-PC be INLINE to reduce consing?
61 ;;; (Are they used in anything time-critical, or just the debugger?)
62 (defun context-register (context index
)
63 (declare (type (alien (* os-context-t
)) context
))
64 (deref (context-register-addr context index
)))
66 (defun %set-context-register
(context index new
)
67 (declare (type (alien (* os-context-t
)) context
))
68 (setf (deref (context-register-addr context index
))
71 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
72 ;;; register. FORMAT is the type of float to return.
74 ;;; FIXME: Whether COERCE actually knows how to make a float out of a
75 ;;; long is another question. This stuff still needs testing.
77 (define-alien-routine ("os_context_float_register_addr" context-float-register-addr
)
79 (context (* os-context-t
))
82 (defun context-float-register (context index format
)
83 (declare (type (alien (* os-context-t
)) context
))
84 (coerce (deref (context-float-register-addr context index
)) format
))
86 (defun %set-context-float-register
(context index format new
)
87 (declare (type (alien (* os-context-t
)) context
))
88 (setf (deref (context-float-register-addr context index
))
91 ;;; Given a signal context, return the floating point modes word in
92 ;;; the same format as returned by FLOATING-POINT-MODES.
94 ;;; Under SunOS, we have a straightforward implementation in C:
96 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
97 (sb!alien
:unsigned
32)
98 (context (* os-context-t
)))
100 ;;; Under Linux, we have to contend with utterly broken signal handling.
102 (defun context-floating-point-modes (context)
103 (warn "stub CONTEXT-FLOATING-POINT-MODES")
106 ;;;; INTERNAL-ERROR-ARGS.
108 ;;; Given a (POSIX) signal context, extract the internal error
109 ;;; arguments from the instruction stream. This is e.g.
110 ;;; 4 23 254 240 2 0 0 0
111 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
112 ;;; length data (everything is an octet)
114 (defun internal-error-args (context)
115 (declare (type (alien (* os-context-t
)) context
))
116 (sb!int
::/show0
"entering INTERNAL-ERROR-ARGS")
117 (let* ((pc (context-pc context
))
118 (bad-inst (sap-ref-32 pc
0))
119 (op (ldb (byte 2 30) bad-inst
))
120 (op2 (ldb (byte 3 22) bad-inst
))
121 (op3 (ldb (byte 6 19) bad-inst
)))
122 (declare (type system-area-pointer pc
))
123 (cond ((and (= op
#b00
) (= op2
#b000
))
124 (args-for-unimp-inst context
))
125 ((and (= op
#b10
) (= (ldb (byte 4 2) op3
) #b1000
))
126 (args-for-tagged-add-inst context bad-inst
))
127 ((and (= op
#b10
) (= op3
#b111010
))
128 (args-for-tcc-inst bad-inst
))
130 (values #.
(error-number-or-lose 'unknown-error
) nil
)))))
132 (defun args-for-unimp-inst (context)
133 (declare (type (alien (* os-context-t
)) context
))
134 (let* ((pc (context-pc context
))
135 (length (sap-ref-8 pc
4))
136 (vector (make-array length
:element-type
'(unsigned-byte 8))))
137 (declare (type system-area-pointer pc
)
138 (type (unsigned-byte 8) length
)
139 (type (simple-array (unsigned-byte 8) (*)) vector
))
140 (copy-from-system-area pc
(* n-byte-bits
5)
141 vector
(* n-word-bits
143 (* length n-byte-bits
))
145 (error-number (sb!c
:read-var-integer vector index
)))
146 (collect ((sc-offsets))
148 (when (>= index length
)
150 (sc-offsets (sb!c
:read-var-integer vector index
)))
151 (values error-number
(sc-offsets))))))
153 (defun args-for-tagged-add-inst (context bad-inst
)
154 (declare (type (alien (* os-context-t
)) context
))
155 (let* ((rs1 (ldb (byte 5 14) bad-inst
))
156 (op1 (sb!kernel
:make-lisp-obj
(context-register context rs1
))))
158 (if (zerop (ldb (byte 1 13) bad-inst
))
159 (let* ((rs2 (ldb (byte 5 0) bad-inst
))
160 (op2 (sb!kernel
:make-lisp-obj
(context-register context rs2
))))
162 (values #.
(error-number-or-lose 'unknown-error
) nil
)
163 (values #.
(error-number-or-lose 'object-not-fixnum-error
)
164 (list (sb!c
::make-sc-offset
165 descriptor-reg-sc-number
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 descriptor-reg-sc-number
172 (defun args-for-tcc-inst (bad-inst)
173 (let* ((trap-number (ldb (byte 8 0) bad-inst
))
174 (reg (ldb (byte 5 8) bad-inst
)))
175 (values (case trap-number
176 (#.object-not-list-trap
177 #.
(error-number-or-lose 'object-not-list-error
))
178 (#.object-not-instance-trap
179 #.
(error-number-or-lose 'object-not-instance-error
))
181 #.
(error-number-or-lose 'unknown-error
)))
182 (list (sb!c
::make-sc-offset descriptor-reg-sc-number reg
)))))