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 (code-instructions code
)))
90 (obj-start-addr (logand (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 (sap-int (code-instructions code
)))
95 (ncode-words (code-header-ref code
1))
96 (code-end-addr (+ code-start-addr
(* ncode-words n-word-bytes
))))
97 (unless (member kind
'(:absolute
:relative
))
98 (error "Unknown code-object-fixup kind ~S." kind
))
101 ;; Word at sap + offset contains a value to be replaced by
102 ;; adding that value to fixup.
103 (setf (sap-ref-32 sap offset
) (+ fixup
(sap-ref-32 sap offset
)))
104 ;; Record absolute fixups that point within the code object.
105 (when (> code-end-addr
(sap-ref-32 sap offset
) obj-start-addr
)
106 (add-fixup code offset
)))
108 ;; Fixup is the actual address wanted.
110 ;; Record relative fixups that point outside the code
112 (when (or (< fixup obj-start-addr
) (> fixup code-end-addr
))
113 (add-fixup code offset
))
114 ;; Replace word with value to add to that loc to get there.
115 (let* ((loc-sap (+ (sap-int sap
) offset
))
116 (rel-val (- fixup loc-sap n-word-bytes
)))
117 (declare (type (unsigned-byte 32) loc-sap
)
118 (type (signed-byte 32) rel-val
))
119 (setf (signed-sap-ref-32 sap offset
) rel-val
))))))
122 ;;;; low-level signal context access functions
124 ;;;; Note: In CMU CL, similar functions were hardwired to access
125 ;;;; BSD-style sigcontext structures defined as alien objects. Our
126 ;;;; approach is different in two ways:
127 ;;;; 1. We use POSIX SA_SIGACTION-style signals, so our context is
128 ;;;; whatever the void pointer in the sigaction handler dereferences
129 ;;;; to, not necessarily a sigcontext.
130 ;;;; 2. We don't try to maintain alien definitions of the context
131 ;;;; structure at Lisp level, but instead call alien C functions
132 ;;;; which take care of access for us. (Since the C functions can
133 ;;;; be defined in terms of system standard header files, they
134 ;;;; should be easier to maintain; and since Lisp code uses signal
135 ;;;; contexts only in interactive or exception code (like the debugger
136 ;;;; and internal error handling) the extra runtime cost should be
139 (declaim (inline context-pc-addr
))
140 (define-alien-routine ("os_context_pc_addr" context-pc-addr
) (* unsigned-int
)
141 ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
142 ;; 'unsigned *' interpretation for the 32-bit word passed to us by
143 ;; the C code, even though the C code may think it's an 'int *'.)
144 (context (* os-context-t
)))
146 (declaim (inline context-pc
))
147 (defun context-pc (context)
148 (declare (type (alien (* os-context-t
)) context
))
149 (let ((addr (context-pc-addr context
)))
150 (declare (type (alien (* unsigned-int
)) addr
))
151 (int-sap (deref addr
))))
153 (declaim (inline context-register-addr
))
154 (define-alien-routine ("os_context_register_addr" context-register-addr
)
156 ;; (Note the mismatch here between the 'int *' value that the C code
157 ;; may think it's giving us and the 'unsigned *' value that we
158 ;; receive. It's intentional: the C header files may think of
159 ;; register values as signed, but the CMU CL code tends to think of
160 ;; register values as unsigned, and might get bewildered if we ask
161 ;; it to work with signed values.)
162 (context (* os-context-t
))
165 (declaim (inline context-register
))
166 (defun context-register (context index
)
167 (declare (type (alien (* os-context-t
)) context
))
168 (let ((addr (context-register-addr context index
)))
169 (declare (type (alien (* unsigned-int
)) addr
))
172 (defun %set-context-register
(context index new
)
173 (declare (type (alien (* os-context-t
)) context
))
174 (let ((addr (context-register-addr context index
)))
175 (declare (type (alien (* unsigned-int
)) addr
))
176 (setf (deref addr
) new
)))
178 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
179 ;;; register. FORMAT is the type of float to return.
181 ;;; As of sbcl-0.6.7, there is no working code which calls this code,
182 ;;; so it's stubbed out. Someday, in order to make the debugger work
183 ;;; better, it may be necessary to unstubify it.
184 (defun context-float-register (context index format
)
185 (declare (ignore context index
))
186 (warn "stub CONTEXT-FLOAT-REGISTER")
188 (defun %set-context-float-register
(context index format new-value
)
189 (declare (ignore context index
))
190 (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
191 (coerce new-value format
))
193 ;;; Given a signal context, return the floating point modes word in
194 ;;; the same format as returned by FLOATING-POINT-MODES.
196 (defun context-floating-point-modes (context)
197 ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
198 ;; POSIXness and (at the Lisp level) opaque signal contexts,
199 ;; this is stubified. It needs to be rewritten as an
201 (declare (ignore context
)) ; stub!
202 (warn "stub CONTEXT-FLOATING-POINT-MODES")
206 (define-alien-routine ("os_context_fp_control" context-floating-point-modes
)
207 (sb!alien
:unsigned
32)
208 (context (* os-context-t
)))
210 ;;;; INTERNAL-ERROR-ARGS
212 ;;; Given a (POSIX) signal context, extract the internal error
213 ;;; arguments from the instruction stream.
214 (defun internal-error-args (context)
215 (declare (type (alien (* os-context-t
)) context
))
216 (/show0
"entering INTERNAL-ERROR-ARGS, CONTEXT=..")
218 (let ((pc (context-pc context
)))
219 (declare (type system-area-pointer pc
))
221 ;; using INT3 the pc is .. INT3 <here> code length bytes...
222 (let* ((length (sap-ref-8 pc
1))
223 (vector (make-array length
:element-type
'(unsigned-byte 8))))
224 (declare (type (unsigned-byte 8) length
)
225 (type (simple-array (unsigned-byte 8) (*)) vector
))
226 (/show0
"LENGTH,VECTOR,ERROR-NUMBER=..")
229 (copy-ub8-from-system-area pc
2 vector
0 length
)
231 (error-number (sb!c
:read-var-integer vector index
)))
232 (/hexstr error-number
)
233 (collect ((sc-offsets))
237 (when (>= index length
)
239 (let ((sc-offset (sb!c
:read-var-integer vector index
)))
240 (/show0
"SC-OFFSET=..")
242 (sc-offsets sc-offset
)))
243 (values error-number
(sc-offsets)))))))
245 ;;; This is used in error.lisp to insure that floating-point exceptions
246 ;;; are properly trapped. The compiler translates this to a VOP.
252 ;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
253 ;;; than the i387 load constant instructions to avoid consing in some
254 ;;; cases. Note these are initialized by GENESIS as they are needed
256 (defvar *fp-constant-0f0
*)
257 (defvar *fp-constant-1f0
*)
258 (defvar *fp-constant-0d0
*)
259 (defvar *fp-constant-1d0
*)
260 ;;; the long-float constants
261 (defvar *fp-constant-0l0
*)
262 (defvar *fp-constant-1l0
*)
263 (defvar *fp-constant-pi
*)
264 (defvar *fp-constant-l2t
*)
265 (defvar *fp-constant-l2e
*)
266 (defvar *fp-constant-lg2
*)
267 (defvar *fp-constant-ln2
*)
269 ;;; the current alien stack pointer; saved/restored for non-local exits
270 (defvar *alien-stack-pointer
*)
272 ;;; Support for the MT19937 random number generator. The update
273 ;;; function is implemented as an assembly routine. This definition is
274 ;;; transformed to a call to the assembly routine allowing its use in
275 ;;; interpreted code.
276 (defun random-mt19937 (state)
277 (declare (type (simple-array (unsigned-byte 32) (627)) state
))
278 (random-mt19937 state
))