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.
98 (defun context-floating-point-modes (context)
99 ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
100 ;; POSIXness and (at the Lisp level) opaque signal contexts,
101 ;; this is stubified. It needs to be rewritten as an
103 (warn "stub CONTEXT-FLOATING-POINT-MODES")
104 ;; old code for Linux:
106 (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
107 (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
108 ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
109 ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
110 (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
111 ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
112 ;; Simulate floating-point-modes VOP.
113 (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
117 ;;;; INTERNAL-ERROR-ARGS.
119 ;;; Given a (POSIX) signal context, extract the internal error
120 ;;; arguments from the instruction stream. This is e.g.
121 ;;; 4 23 254 240 2 0 0 0
122 ;;; | ~~~~~~~~~~~~~~~~~~~~~~~~~
123 ;;; length data (everything is an octet)
125 (defun internal-error-args (context)
126 (declare (type (alien (* os-context-t)) context))
127 (sb!int::/show0 "entering INTERNAL-ERROR-ARGS")
128 (let* ((pc (context-pc context))
129 (bad-inst (sap-ref-32 pc 0))
130 (op (ldb (byte 2 30) bad-inst))
131 (op2 (ldb (byte 3 22) bad-inst))
132 (op3 (ldb (byte 6 19) bad-inst)))
133 (declare (type system-area-pointer pc))
134 (cond ((and (= op #b00) (= op2 #b000))
135 (args-for-unimp-inst context))
136 ((and (= op #b10) (= (ldb (byte 4 2) op3) #b1000))
137 (args-for-tagged-add-inst context bad-inst))
138 ((and (= op #b10) (= op3 #b111010))
139 (args-for-tcc-inst bad-inst))
141 (values #.(error-number-or-lose 'unknown-error) nil)))))
143 (defun args-for-unimp-inst (context)
144 (declare (type (alien (* os-context-t)) context))
145 (let* ((pc (context-pc context))
146 (length (sap-ref-8 pc 4))
147 (vector (make-array length :element-type '(unsigned-byte 8))))
148 (declare (type system-area-pointer pc)
149 (type (unsigned-byte 8) length)
150 (type (simple-array (unsigned-byte 8) (*)) vector))
151 (copy-from-system-area pc (* n-byte-bits 5)
152 vector (* n-word-bits
154 (* length n-byte-bits))
156 (error-number (sb!c::read-var-integer vector index)))
157 (collect ((sc-offsets))
159 (when (>= index length)
161 (sc-offsets (sb!c::read-var-integer vector index)))
162 (values error-number (sc-offsets))))))
164 (defun args-for-tagged-add-inst (context bad-inst)
165 (declare (type (alien (* os-context-t)) context))
166 (let* ((rs1 (ldb (byte 5 14) bad-inst))
167 (op1 (sb!kernel:make-lisp-obj (context-register context rs1))))
169 (if (zerop (ldb (byte 1 13) bad-inst))
170 (let* ((rs2 (ldb (byte 5 0) bad-inst))
171 (op2 (sb!kernel:make-lisp-obj (context-register context rs2))))
173 (values #.(error-number-or-lose 'unknown-error) nil)
174 (values #.(error-number-or-lose 'object-not-fixnum-error)
175 (list (sb!c::make-sc-offset
176 descriptor-reg-sc-number
178 (values #.(error-number-or-lose 'unknown-error) nil))
179 (values #.(error-number-or-lose 'object-not-fixnum-error)
180 (list (sb!c::make-sc-offset descriptor-reg-sc-number
183 (defun args-for-tcc-inst (bad-inst)
184 (let* ((trap-number (ldb (byte 8 0) bad-inst))
185 (reg (ldb (byte 5 8) bad-inst)))
186 (values (case trap-number
187 (#.object-not-list-trap
188 #.(error-number-or-lose 'object-not-list-error))
189 (#.object-not-instance-trap
190 #.(error-number-or-lose 'object-not-instance-error))
192 #.(error-number-or-lose 'unknown-error)))
193 (list (sb!c::make-sc-offset descriptor-reg-sc-number reg)))))
196 ;;; Do whatever is necessary to make the given code component
197 ;;; executable. On the sparc, we don't need to do anything, because
198 ;;; the i and d caches are unified.
199 (defun sanctify-for-execution (component)
200 (declare (ignore component))