1.0.23.6: move code-object allocation to C side on x86 and x86-64
[sbcl.git] / src / code / x86-vm.lisp
1 ;;;; X86-specific runtime stuff
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; OS-CONTEXT-T
15
16 ;;; a POSIX signal context, i.e. the type passed as the third
17 ;;; argument to an SA_SIGACTION-style signal handler
18 ;;;
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.
25 ;;;
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
31 ;;;
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))
36 \f
37 ;;;; MACHINE-TYPE and MACHINE-VERSION
38
39 (defun machine-type ()
40   #!+sb-doc
41   "Return a string describing the type of the local machine."
42   "X86")
43
44 ;;; arch-specific support for CL:MACHINE-VERSION, defined OAOO elsewhere
45 (defun get-machine-version ()
46   #!+linux
47   (with-open-file (stream "/proc/cpuinfo"
48                           ;; Even on Linux it's an option to build
49                           ;; kernels without /proc filesystems, so
50                           ;; degrade gracefully.
51                           :if-does-not-exist nil)
52     (loop with line while (setf line (read-line stream nil))
53           ;; The field "model name" exists on kernel 2.4.21-rc6-ac1
54           ;; anyway, with values e.g.
55           ;;   "AMD Athlon(TM) XP 2000+"
56           ;;   "Intel(R) Pentium(R) M processor 1300MHz"
57           ;; which seem comparable to the information in the example
58           ;; in the MACHINE-VERSION page of the ANSI spec.
59           when (eql (search "model name" line) 0)
60           return (string-trim " " (subseq line (1+ (position #\: line))))))
61   #!-linux
62   nil)
63 \f
64 ;;;; :CODE-OBJECT fixups
65
66 ;;; a counter to measure the storage overhead of these fixups
67 (defvar *num-fixups* 0)
68 ;;; FIXME: When the system runs, it'd be interesting to see what this is.
69
70 (declaim (inline adjust-fixup-array))
71 (defun adjust-fixup-array (array size)
72   (let ((new (make-array size :element-type '(unsigned-byte 32))))
73     (replace new array)
74     new))
75
76 ;;; This gets called by LOAD to resolve newly positioned objects
77 ;;; with things (like code instructions) that have to refer to them.
78 ;;;
79 ;;; Add a fixup offset to the vector of fixup offsets for the given
80 ;;; code object.
81 (defun fixup-code-object (code offset fixup kind)
82   (declare (type index offset))
83   (flet ((add-fixup (code offset)
84            ;; (We check for and ignore fixups for code objects in the
85            ;; read-only and static spaces. (In the old CMU CL code
86            ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*,
87            ;; but in SBCL relocatable dynamic space code is always in
88            ;; use, so we always do the check.)
89            (incf *num-fixups*)
90            (let ((fixups (code-header-ref code code-constants-offset)))
91              (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
92                     (let ((new-fixups
93                            (adjust-fixup-array fixups (1+ (length fixups)))))
94                       (setf (aref new-fixups (length fixups)) offset)
95                       (setf (code-header-ref code code-constants-offset)
96                             new-fixups)))
97                    (t
98                     (unless (or (eq (widetag-of fixups)
99                                     unbound-marker-widetag)
100                                 (zerop fixups))
101                       (format t "** Init. code FU = ~S~%" fixups)) ; FIXME
102                     (setf (code-header-ref code code-constants-offset)
103                           (make-array
104                            1
105                            :element-type '(unsigned-byte 32)
106                            :initial-element offset)))))))
107     (sb!sys:without-gcing
108      (let* ((sap (truly-the system-area-pointer
109                             (sb!kernel:code-instructions code)))
110             (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code)
111                                     #xfffffff8))
112             ;; FIXME: what is this 5?
113             #+nil (const-start-addr (+ obj-start-addr (* 5 n-word-bytes)))
114             (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
115                                               code)))
116             (ncode-words (sb!kernel:code-header-ref code 1))
117             (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes))))
118        (unless (member kind '(:absolute :relative))
119          (error "Unknown code-object-fixup kind ~S." kind))
120        (ecase kind
121          (:absolute
122           ;; Word at sap + offset contains a value to be replaced by
123           ;; adding that value to fixup.
124           (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
125           ;; Record absolute fixups that point within the code object.
126           (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
127             (add-fixup code offset)))
128          (:relative
129           ;; Fixup is the actual address wanted.
130           ;;
131           ;; Record relative fixups that point outside the code
132           ;; object.
133           (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
134             (add-fixup code offset))
135           ;; Replace word with value to add to that loc to get there.
136           (let* ((loc-sap (+ (sap-int sap) offset))
137                  (rel-val (- fixup loc-sap n-word-bytes)))
138             (declare (type (unsigned-byte 32) loc-sap)
139                      (type (signed-byte 32) rel-val))
140             (setf (signed-sap-ref-32 sap offset) rel-val))))))
141     nil))
142
143 ;;; Add a code fixup to a code object generated by GENESIS. The fixup
144 ;;; has already been applied, it's just a matter of placing the fixup
145 ;;; in the code's fixup vector if necessary.
146 ;;;
147 ;;; KLUDGE: I'd like a good explanation of why this has to be done at
148 ;;; load time instead of in GENESIS. It's probably simple, I just haven't
149 ;;; figured it out, or found it written down anywhere. -- WHN 19990908
150 #!+gencgc
151 (defun !envector-load-time-code-fixup (code offset fixup kind)
152   (flet ((frob (code offset)
153            (let ((fixups (code-header-ref code code-constants-offset)))
154              (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
155                     (let ((new-fixups
156                            (adjust-fixup-array fixups (1+ (length fixups)))))
157                       (setf (aref new-fixups (length fixups)) offset)
158                       (setf (code-header-ref code code-constants-offset)
159                             new-fixups)))
160                    (t
161                     (unless (or (eq (widetag-of fixups)
162                                     unbound-marker-widetag)
163                                 (zerop fixups))
164                       (sb!impl::!cold-lose "Argh! can't process fixup"))
165                     (setf (code-header-ref code code-constants-offset)
166                           (make-array
167                            1
168                            :element-type '(unsigned-byte 32)
169                            :initial-element offset)))))))
170     (let* ((sap (truly-the system-area-pointer
171                            (sb!kernel:code-instructions code)))
172            (obj-start-addr
173             ;; FIXME: looks like (LOGANDC2 foo typebits)
174             (logand (sb!kernel:get-lisp-obj-address code) #xfffffff8))
175            (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
176                                              code)))
177            (ncode-words (sb!kernel:code-header-ref code 1))
178          (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes))))
179       (ecase kind
180         (:absolute
181          ;; Record absolute fixups that point within the code object.
182          (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
183            (frob code offset)))
184         (:relative
185          ;; Record relative fixups that point outside the code object.
186          (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
187            (frob code offset)))))))
188 \f
189 ;;;; low-level signal context access functions
190 ;;;;
191 ;;;; Note: In CMU CL, similar functions were hardwired to access
192 ;;;; BSD-style sigcontext structures defined as alien objects. Our
193 ;;;; approach is different in two ways:
194 ;;;;   1. We use POSIX SA_SIGACTION-style signals, so our context is
195 ;;;;      whatever the void pointer in the sigaction handler dereferences
196 ;;;;      to, not necessarily a sigcontext.
197 ;;;;   2. We don't try to maintain alien definitions of the context
198 ;;;;      structure at Lisp level, but instead call alien C functions
199 ;;;;      which take care of access for us. (Since the C functions can
200 ;;;;      be defined in terms of system standard header files, they
201 ;;;;      should be easier to maintain; and since Lisp code uses signal
202 ;;;;      contexts only in interactive or exception code (like the debugger
203 ;;;;      and internal error handling) the extra runtime cost should be
204 ;;;;      negligible.
205
206 (declaim (inline context-pc-addr))
207 (define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
208   ;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
209   ;; 'unsigned *' interpretation for the 32-bit word passed to us by
210   ;; the C code, even though the C code may think it's an 'int *'.)
211   (context (* os-context-t)))
212
213 (declaim (inline context-pc))
214 (defun context-pc (context)
215   (declare (type (alien (* os-context-t)) context))
216   (let ((addr (context-pc-addr context)))
217     (declare (type (alien (* unsigned-int)) addr))
218     (int-sap (deref addr))))
219
220 (declaim (inline context-register-addr))
221 (define-alien-routine ("os_context_register_addr" context-register-addr)
222   (* unsigned-int)
223   ;; (Note the mismatch here between the 'int *' value that the C code
224   ;; may think it's giving us and the 'unsigned *' value that we
225   ;; receive. It's intentional: the C header files may think of
226   ;; register values as signed, but the CMU CL code tends to think of
227   ;; register values as unsigned, and might get bewildered if we ask
228   ;; it to work with signed values.)
229   (context (* os-context-t))
230   (index int))
231
232 (declaim (inline context-register))
233 (defun context-register (context index)
234   (declare (type (alien (* os-context-t)) context))
235   (let ((addr (context-register-addr context index)))
236     (declare (type (alien (* unsigned-int)) addr))
237     (deref addr)))
238
239 (defun %set-context-register (context index new)
240   (declare (type (alien (* os-context-t)) context))
241   (let ((addr (context-register-addr context index)))
242     (declare (type (alien (* unsigned-int)) addr))
243     (setf (deref addr) new)))
244
245 ;;; This is like CONTEXT-REGISTER, but returns the value of a float
246 ;;; register. FORMAT is the type of float to return.
247 ;;;
248 ;;; As of sbcl-0.6.7, there is no working code which calls this code,
249 ;;; so it's stubbed out. Someday, in order to make the debugger work
250 ;;; better, it may be necessary to unstubify it.
251 (defun context-float-register (context index format)
252   (declare (ignore context index))
253   (warn "stub CONTEXT-FLOAT-REGISTER")
254   (coerce 0.0 format))
255 (defun %set-context-float-register (context index format new-value)
256   (declare (ignore context index))
257   (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
258   (coerce new-value format))
259
260 ;;; Given a signal context, return the floating point modes word in
261 ;;; the same format as returned by FLOATING-POINT-MODES.
262 #!-(or linux sunos)
263 (defun context-floating-point-modes (context)
264   ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
265   ;; POSIXness and (at the Lisp level) opaque signal contexts,
266   ;; this is stubified. It needs to be rewritten as an
267   ;; alien function.
268   (declare (ignore context)) ; stub!
269   (warn "stub CONTEXT-FLOATING-POINT-MODES")
270   0)
271
272 #!+(or linux sunos)
273 (define-alien-routine ("os_context_fp_control" context-floating-point-modes)
274     (sb!alien:unsigned 32)
275   (context (* os-context-t)))
276 \f
277 ;;;; INTERNAL-ERROR-ARGS
278
279 ;;; Given a (POSIX) signal context, extract the internal error
280 ;;; arguments from the instruction stream.
281 (defun internal-error-args (context)
282   (declare (type (alien (* os-context-t)) context))
283   (/show0 "entering INTERNAL-ERROR-ARGS, CONTEXT=..")
284   (/hexstr context)
285   (let ((pc (context-pc context)))
286     (declare (type system-area-pointer pc))
287     (/show0 "got PC")
288     ;; using INT3 the pc is .. INT3 <here> code length bytes...
289     (let* ((length (sap-ref-8 pc 1))
290            (vector (make-array length :element-type '(unsigned-byte 8))))
291       (declare (type (unsigned-byte 8) length)
292                (type (simple-array (unsigned-byte 8) (*)) vector))
293       (/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
294       (/hexstr length)
295       (/hexstr vector)
296       (copy-ub8-from-system-area pc 2 vector 0 length)
297       (let* ((index 0)
298              (error-number (sb!c:read-var-integer vector index)))
299         (/hexstr error-number)
300         (collect ((sc-offsets))
301           (loop
302            (/show0 "INDEX=..")
303            (/hexstr index)
304            (when (>= index length)
305              (return))
306            (let ((sc-offset (sb!c:read-var-integer vector index)))
307              (/show0 "SC-OFFSET=..")
308              (/hexstr sc-offset)
309              (sc-offsets sc-offset)))
310           (values error-number (sc-offsets)))))))
311 \f
312 ;;; This is used in error.lisp to insure that floating-point exceptions
313 ;;; are properly trapped. The compiler translates this to a VOP.
314 (defun float-wait ()
315   (float-wait))
316
317 ;;; float constants
318 ;;;
319 ;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather
320 ;;; than the i387 load constant instructions to avoid consing in some
321 ;;; cases. Note these are initialized by GENESIS as they are needed
322 ;;; early.
323 (defvar *fp-constant-0f0*)
324 (defvar *fp-constant-1f0*)
325 (defvar *fp-constant-0d0*)
326 (defvar *fp-constant-1d0*)
327 ;;; the long-float constants
328 (defvar *fp-constant-0l0*)
329 (defvar *fp-constant-1l0*)
330 (defvar *fp-constant-pi*)
331 (defvar *fp-constant-l2t*)
332 (defvar *fp-constant-l2e*)
333 (defvar *fp-constant-lg2*)
334 (defvar *fp-constant-ln2*)
335
336 ;;; the current alien stack pointer; saved/restored for non-local exits
337 (defvar *alien-stack*)
338
339 ;;; Support for the MT19937 random number generator. The update
340 ;;; function is implemented as an assembly routine. This definition is
341 ;;; transformed to a call to the assembly routine allowing its use in
342 ;;; interpreted code.
343 (defun random-mt19937 (state)
344   (declare (type (simple-array (unsigned-byte 32) (627)) state))
345   (random-mt19937 state))