1 ;;;; X86-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.
16 ;;; a POSIX signal context, i.e. the type passed as the third
17 ;;; argument to an SA_SIGACTION-style signal handler
19 ;;; The real type does have slots, but at Lisp level, we never
20 ;;; access them, or care about the size of the object. Instead, we
21 ;;; always refer to these objects by pointers handed to us by the C
22 ;;; runtime library, and ask the runtime library any time we need
23 ;;; information about the contents of one of these objects. Thus, it
24 ;;; works to represent this as an object with no slots.
26 ;;; KLUDGE: It would be nice to have a type definition analogous to
27 ;;; C's "struct os_context_t;", for an incompletely specified object
28 ;;; which can only be referred to by reference, but I don't know how
29 ;;; to do that in the FFI, so instead we just this bogus no-slots
30 ;;; representation. -- WHN 20000730
32 ;;; FIXME: Since SBCL, unlike CMU CL, uses this as an opaque type,
33 ;;; it's no longer architecture-dependent, and probably belongs in
34 ;;; some other package, perhaps SB-KERNEL.
35 (define-alien-type os-context-t
(struct os-context-t-struct
))
39 (defun machine-type ()
41 "Return a string describing the type of the local machine."
44 ;;;; :CODE-OBJECT fixups
46 ;;; a counter to measure the storage overhead of these fixups
47 (defvar *num-fixups
* 0)
48 ;;; FIXME: When the system runs, it'd be interesting to see what this is.
50 (declaim (inline adjust-fixup-array
))
51 (defun adjust-fixup-array (array size
)
52 (let ((new (make-array size
:element-type
'(unsigned-byte 32))))
56 ;;; This gets called by LOAD to resolve newly positioned objects
57 ;;; with things (like code instructions) that have to refer to them.
59 ;;; Add a fixup offset to the vector of fixup offsets for the given
61 (defun fixup-code-object (code offset fixup kind
)
62 (declare (type index offset
))
63 (flet ((add-fixup (code offset
)
64 ;; (We check for and ignore fixups for code objects in the
65 ;; read-only and static spaces. (In the old CMU CL code
66 ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*,
67 ;; but in SBCL relocatable dynamic space code is always in
68 ;; use, so we always do the check.)
70 (let ((fixups (code-header-ref code code-constants-offset
)))
71 (cond ((typep fixups
'(simple-array (unsigned-byte 32) (*)))
73 (adjust-fixup-array fixups
(1+ (length fixups
)))))
74 (setf (aref new-fixups
(length fixups
)) offset
)
75 (setf (code-header-ref code code-constants-offset
)
78 (unless (or (eq (widetag-of fixups
)
79 unbound-marker-widetag
)
81 (format t
"** Init. code FU = ~S~%" fixups
)) ; FIXME
82 (setf (code-header-ref code code-constants-offset
)
85 :element-type
'(unsigned-byte 32)
86 :initial-element offset
)))))))
88 (let* ((sap (truly-the system-area-pointer
89 (sb!kernel
:code-instructions code
)))
90 (obj-start-addr (logand (sb!kernel
:get-lisp-obj-address code
)
92 ;; FIXME: what is this 5?
93 #+nil
(const-start-addr (+ obj-start-addr
(* 5 n-word-bytes
)))
94 (code-start-addr (sb!sys
:sap-int
(sb!kernel
:code-instructions
96 (ncode-words (sb!kernel
:code-header-ref code
1))
97 (code-end-addr (+ code-start-addr
(* ncode-words n-word-bytes
))))
98 (unless (member kind
'(:absolute
:relative
))
99 (error "Unknown code-object-fixup kind ~S." kind
))
102 ;; Word at sap + offset contains a value to be replaced by
103 ;; adding that value to fixup.
104 (setf (sap-ref-32 sap offset
) (+ fixup
(sap-ref-32 sap offset
)))
105 ;; Record absolute fixups that point within the code object.
106 (when (> code-end-addr
(sap-ref-32 sap offset
) obj-start-addr
)
107 (add-fixup code offset
)))
109 ;; Fixup is the actual address wanted.
111 ;; Record relative fixups that point outside the code
113 (when (or (< fixup obj-start-addr
) (> fixup code-end-addr
))
114 (add-fixup code offset
))
115 ;; Replace word with value to add to that loc to get there.
116 (let* ((loc-sap (+ (sap-int sap
) offset
))
117 (rel-val (- fixup loc-sap n-word-bytes
)))
118 (declare (type (unsigned-byte 32) loc-sap
)
119 (type (signed-byte 32) rel-val
))
120 (setf (signed-sap-ref-32 sap offset
) rel-val
))))))
123 ;;;; low-level signal context access functions
125 ;;;; Note: In CMU CL, similar functions were hardwired to access
126 ;;;; BSD-style sigcontext structures defined as alien objects. Our
127 ;;;; approach is different in two ways:
128 ;;;; 1. We use POSIX SA_SIGACTION-style signals, so our context is
129 ;;;; whatever the void pointer in the sigaction handler dereferences
130 ;;;; to, not necessarily a sigcontext.
131 ;;;; 2. We don't try to maintain alien definitions of the context
132 ;;;; structure at Lisp level, but instead call alien C functions
133 ;;;; which take care of access for us. (Since the C functions can
134 ;;;; be defined in terms of system standard header files, they
135 ;;;; should be easier to maintain; and since Lisp code uses signal
136 ;;;; contexts only in interactive or exception code (like the debugger
137 ;;;; and internal error handling) the extra runtime cost should be
140 (declaim (inline context-pc-addr
))
141 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-int
)
142 ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
143 ;; 'unsigned *' interpretation for the 32-bit word passed to us by
144 ;; the C code, even though the C code may think it's an 'int *'.)
145 (context (* os-context-t
)))
147 (declaim (inline context-pc
))
148 (defun context-pc (context)
149 (declare (type (alien (* os-context-t
)) context
))
150 (let ((addr (context-pc-addr context
)))
151 (declare (type (alien (* unsigned-int
)) addr
))
152 (int-sap (deref addr
))))
154 (declaim (inline context-register-addr
))
155 (define-alien-routine ("os_context_register_addr" context-register-addr
)
157 ;; (Note the mismatch here between the 'int *' value that the C code
158 ;; may think it's giving us and the 'unsigned *' value that we
159 ;; receive. It's intentional: the C header files may think of
160 ;; register values as signed, but the CMU CL code tends to think of
161 ;; register values as unsigned, and might get bewildered if we ask
162 ;; it to work with signed values.)
163 (context (* os-context-t
))
166 (declaim (inline context-register
))
167 (defun context-register (context index
)
168 (declare (type (alien (* os-context-t
)) context
))
169 (let ((addr (context-register-addr context index
)))
170 (declare (type (alien (* unsigned-int
)) addr
))
173 (defun %set-context-register
(context index new
)
174 (declare (type (alien (* os-context-t
)) context
))
175 (let ((addr (context-register-addr context index
)))
176 (declare (type (alien (* unsigned-int
)) addr
))
177 (setf (deref addr
) new
)))
179 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
180 ;;; register. FORMAT is the type of float to return.
182 ;;; As of sbcl-0.6.7, there is no working code which calls this code,
183 ;;; so it's stubbed out. Someday, in order to make the debugger work
184 ;;; better, it may be necessary to unstubify it.
185 (defun context-float-register (context index format
)
186 (declare (ignore context index
))
187 (warn "stub CONTEXT-FLOAT-REGISTER")
189 (defun %set-context-float-register
(context index format new-value
)
190 (declare (ignore context index
))
191 (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
192 (coerce new-value format
))
194 ;;; Given a signal context, return the floating point modes word in
195 ;;; the same format as returned by FLOATING-POINT-MODES.
197 (defun context-floating-point-modes (context)
198 ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
199 ;; POSIXness and (at the Lisp level) opaque signal contexts,
200 ;; this is stubified. It needs to be rewritten as an
202 (declare (ignore context
)) ; stub!
203 (warn "stub CONTEXT-FLOATING-POINT-MODES")
207 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
208 (sb!alien
:unsigned
32)
209 (context (* os-context-t
)))
211 ;;;; INTERNAL-ERROR-ARGS
213 ;;; Given a (POSIX) signal context, extract the internal error
214 ;;; arguments from the instruction stream.
215 (defun internal-error-args (context)
216 (declare (type (alien (* os-context-t
)) context
))
217 (/show0
"entering INTERNAL-ERROR-ARGS, CONTEXT=..")
219 (let ((pc (context-pc context
)))
220 (declare (type system-area-pointer pc
))
222 ;; using INT3 the pc is .. INT3 <here> code length bytes...
223 (let* ((length (sap-ref-8 pc
1))
224 (vector (make-array length
:element-type
'(unsigned-byte 8))))
225 (declare (type (unsigned-byte 8) length
)
226 (type (simple-array (unsigned-byte 8) (*)) vector
))
227 (/show0
"LENGTH,VECTOR,ERROR-NUMBER=..")
230 (copy-ub8-from-system-area pc
2 vector
0 length
)
232 (error-number (sb!c
:read-var-integer vector index
)))
233 (/hexstr error-number
)
234 (collect ((sc-offsets))
238 (when (>= index length
)
240 (let ((sc-offset (sb!c
:read-var-integer vector index
)))
241 (/show0
"SC-OFFSET=..")
243 (sc-offsets sc-offset
)))
244 (values error-number
(sc-offsets)))))))
246 ;;; This is used in error.lisp to insure that floating-point exceptions
247 ;;; are properly trapped. The compiler translates this to a VOP.
253 ;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
254 ;;; than the i387 load constant instructions to avoid consing in some
255 ;;; cases. Note these are initialized by GENESIS as they are needed
257 (defvar *fp-constant-0f0
*)
258 (defvar *fp-constant-1f0
*)
259 (defvar *fp-constant-0d0
*)
260 (defvar *fp-constant-1d0
*)
261 ;;; the long-float constants
262 (defvar *fp-constant-0l0
*)
263 (defvar *fp-constant-1l0
*)
264 (defvar *fp-constant-pi
*)
265 (defvar *fp-constant-l2t
*)
266 (defvar *fp-constant-l2e
*)
267 (defvar *fp-constant-lg2
*)
268 (defvar *fp-constant-ln2
*)
270 ;;; the current alien stack pointer; saved/restored for non-local exits
271 (defvar *alien-stack
*)
273 ;;; Support for the MT19937 random number generator. The update
274 ;;; function is implemented as an assembly routine. This definition is
275 ;;; transformed to a call to the assembly routine allowing its use in
276 ;;; interpreted code.
277 (defun random-mt19937 (state)
278 (declare (type (simple-array (unsigned-byte 32) (627)) state
))
279 (random-mt19937 state
))