/[cmucl]/src/code/x86-vm.lisp
ViewVC logotype

Contents of /src/code/x86-vm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Sat Nov 8 15:54:20 1997 UTC (16 years, 5 months ago) by dtc
Branch: MAIN
Changes since 1.6: +53 -19 lines
Add support for saving the offsets of fixups in native code. This
allows purify and the garbage collector (currently only GENCGC) to
move the code objects so they can be placed in the dynamic space and
garbage collected.

Remove the make-complex-{single,double}-float functions which are no
longer used.

Defvar for *scavenge-read-only-space*.
1 ;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: X86 -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.7 1997/11/08 15:54:20 dtc Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file contains the X86 specific runtime stuff.
15 ;;;
16
17 (in-package "X86")
18 (use-package "SYSTEM")
19 (use-package "ALIEN")
20 (use-package "C-CALL")
21 (use-package "UNIX")
22 (use-package "KERNEL")
23
24 (export '(fixup-code-object internal-error-arguments
25 sigcontext-program-counter sigcontext-register
26 sigcontext-float-register sigcontext-floating-point-modes
27 extern-alien-name sanctify-for-execution
28 alternate-get-global-address))
29
30
31 ;;;; The sigcontext structure.
32 ;;;; Add machine specific features to *features*
33
34 (pushnew :x86 *features*)
35
36
37
38 #+linux
39 (def-alien-type nil
40 (struct fpreg
41 (significand (array unsigned-short 4))
42 (exponent unsigned-short)))
43 #+linux
44 (def-alien-type nil
45 (struct fpstate
46 (cw unsigned-long)
47 (sw unsigned-long)
48 (tag unsigned-long)
49 (ipoff unsigned-long)
50 (cssel unsigned-long)
51 (dataoff unsigned-long)
52 (datasel unsigned-long)
53 (fpreg (array (struct fpreg) 8))
54 (status unsigned-long)))
55
56 ;;; for FreeBSD
57 #+freebsd
58 (def-alien-type sigcontext
59 (struct nil
60 (sc-onstack unsigned-int)
61 (sc-mask unsigned-int)
62 (sc-sp unsigned-int)
63 (sc-fp unsigned-int)
64 (sc-isp unsigned-int)
65 (sc-pc unsigned-int)
66 (sc-efl unsigned-int) ; sc_ps
67 (sc-es unsigned-int)
68 (sc-ds unsigned-int)
69 (sc-cs unsigned-int)
70 (sc-ss unsigned-int)
71 (sc-edi unsigned-int)
72 (sc-esi unsigned-int)
73 (sc-ebx unsigned-int)
74 (sc-edx unsigned-int)
75 (sc-ecx unsigned-int)
76 (sc-eax unsigned-int)))
77
78 ;; For Linux...
79 #+linux
80 (def-alien-type sigcontext
81 (struct nil
82 (gs unsigned-short)
83 (__gsh unsigned-short)
84 (fs unsigned-short)
85 (__fsh unsigned-short)
86 (sc-es unsigned-short)
87 (__esh unsigned-short)
88 (sc-ds unsigned-short)
89 (__dsh unsigned-short)
90 (sc-edi unsigned-long)
91 (sc-esi unsigned-long)
92 (ebp unsigned-long)
93 (sc-sp unsigned-long)
94 (sc-ebx unsigned-long)
95 (sc-edx unsigned-long)
96 (sc-ecx unsigned-long)
97 (sc-eax unsigned-long)
98 (trapno unsigned-long)
99 (err unsigned-long)
100 (sc-pc unsigned-long)
101 (sc-cs unsigned-short)
102 (__csh unsigned-short)
103 (sc-efl unsigned-long)
104 (esp_at_signal unsigned-long)
105 (sc-ss unsigned-short)
106 (__ssh unsigned-short)
107 ; (fpstate unsigned-long) ;; fpstate struct pointer
108 (fpstate (* (struct fpstate)))
109 (sc-mask unsigned-long)
110 (cr2 unsigned-long)))
111
112
113
114 ;;;; MACHINE-TYPE and MACHINE-VERSION
115
116 #-cross-compiler
117 (defun machine-type ()
118 "Returns a string describing the type of the local machine."
119 "X86")
120
121
122 #-cross-compiler
123 (defun machine-version ()
124 "Returns a string describing the version of the local machine."
125 "X86")
126
127
128
129 ;;; FIXUP-CODE-OBJECT -- Interface
130 ;;; This gets called by LOAD to resolve newly positioned objects
131 ;;; with things (like code instructions) that have to refer to them.
132
133 ;;; Add a fixup offset to the vector of fixup offsets for the given
134 ;;; code object.
135 ;;;
136 ;;; Counter to measure the storage overhead.
137 (defvar *num-fixups* 0)
138 ;;;
139 (defun add-fixup (code offset)
140 ;; Although this could check for and ignore fixups for code objects
141 ;; in the read-only and static spaces, this should only be the case
142 ;; when *enable-dynamic-space-code* is True.
143 (when lisp::*enable-dynamic-space-code*
144 (incf *num-fixups*)
145 (let ((fixups (code-header-ref code code-constants-offset)))
146 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
147 (let ((new-fixups
148 (adjust-array fixups (1+ (length fixups))
149 :element-type '(unsigned-byte 32))))
150 (setf (aref new-fixups (length fixups)) offset)
151 (setf (code-header-ref code code-constants-offset)
152 new-fixups)))
153 (t
154 (unless (or (eq (get-type fixups) x86:unbound-marker-type)
155 (zerop fixups))
156 (format t "** Init. code FU = ~s~%" fixups))
157 (setf (code-header-ref code code-constants-offset)
158 (make-array 1 :element-type '(unsigned-byte 32)
159 :initial-element offset)))))))
160
161
162 (defun fixup-code-object (code offset fixup kind)
163 (declare (type index offset))
164 (system:without-gcing
165 (let* ((sap (truly-the system-area-pointer (c::code-instructions code)))
166 (obj-start-addr (logand (kernel::get-lisp-obj-address code)
167 #xfffffff8))
168 #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
169 (code-start-addr (c::sap-int (kernel::code-instructions code)))
170 (ncode-words (kernel::code-header-ref code 1))
171 (code-end-addr (+ code-start-addr (* ncode-words 4))))
172 (unless (member kind '(:absolute :relative))
173 (error "Unknown code-object-fixup kind ~s." kind))
174 (ecase kind
175 (:absolute
176 ;; word at sap + offset contains a value to be replaced by
177 ;; adding that value to fixup.
178 (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
179 ;; Record absolute fixups that point within the code object.
180 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
181 (add-fixup code offset)))
182 (:relative
183 ;; Fixup is the actual address wanted.
184 ;;
185 ;; Record relative fixups that point outside the code object.
186 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
187 (add-fixup code offset))
188 ;; Replace word with value to add to that loc to get there.
189 (let* ((loc-sap (+ (sap-int sap) offset))
190 (rel-val (- fixup loc-sap 4)))
191 (declare (type (unsigned-byte 32) loc-sap)
192 (type (signed-byte 32) rel-val))
193 (setf (sap-ref-32 sap offset) rel-val)) ))))
194 nil)
195
196
197
198 ;;;; Internal-error-arguments.
199
200 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
201 ;;;
202 ;;; Given the sigcontext, extract the internal error arguments from the
203 ;;; instruction stream.
204 ;;;
205 (defun internal-error-arguments (scp)
206 (declare (type (alien (* sigcontext)) scp))
207 (with-alien ((scp (* sigcontext) scp))
208 (let ((pc (int-sap (slot scp 'sc-pc))))
209 (declare (type system-area-pointer pc))
210 ;; using INT3 the pc is .. INT3 <here> code length bytes...
211 (let* ((length (sap-ref-8 pc 1))
212 (vector (make-array length :element-type '(unsigned-byte 8))))
213 (declare (type (unsigned-byte 8) length)
214 (type (simple-array (unsigned-byte 8) (*)) vector))
215 (copy-from-system-area pc (* vm:byte-bits 2)
216 vector (* vm:word-bits
217 vm:vector-data-offset)
218 (* length vm:byte-bits))
219 (let* ((index 0)
220 (error-number (c::read-var-integer vector index)))
221 (collect ((sc-offsets))
222 (loop
223 (when (>= index length)
224 (return))
225 (sc-offsets (c::read-var-integer vector index)))
226 (values error-number (sc-offsets))))))))
227
228
229 ;;;; Sigcontext access functions.
230
231 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
232 ;;;
233 (defun sigcontext-program-counter (scp)
234 (declare (type (alien (* sigcontext)) scp))
235 (with-alien ((scp (* sigcontext) scp))
236 (int-sap (slot scp 'sc-pc))))
237
238 ;;; SIGCONTEXT-REGISTER -- Interface.
239 ;;;
240 ;;; An escape register saves the value of a register for a frame that someone
241 ;;; interrupts.
242 ;;;
243
244 (defun sigcontext-register (scp index)
245 (declare (type (alien (* sigcontext)) scp))
246 (with-alien ((scp (* sigcontext) scp))
247 (case index ; ugly -- I know.
248 (#.eax-offset (slot scp 'sc-eax))
249 (#.ecx-offset (slot scp 'sc-ecx))
250 (#.edx-offset (slot scp 'sc-edx))
251 (#.ebx-offset (slot scp 'sc-ebx))
252 (#.esp-offset (slot scp 'sc-sp))
253 #-linux (#.ebp-offset (slot scp 'sc-fp))
254 #+linux (#.ebp-offset (slot scp 'ebp))
255 (#.esi-offset (slot scp 'sc-esi))
256 (#.edi-offset (slot scp 'sc-edi)))))
257
258
259 (defun %set-sigcontext-register (scp index new)
260 (declare (type (alien (* sigcontext)) scp))
261 (with-alien ((scp (* sigcontext) scp))
262 (case index
263 (#.eax-offset (setf (slot scp 'sc-eax) new))
264 (#.ecx-offset (setf (slot scp 'sc-ecx) new))
265 (#.edx-offset (setf (slot scp 'sc-edx) new))
266 (#.ebx-offset (setf (slot scp 'sc-ebx) new))
267 (#.esp-offset (setf (slot scp 'sc-sp) new))
268 #-linux (#.ebp-offset (setf (slot scp 'sc-fp) new))
269 #+linux (#.ebp-offset (setf (slot scp 'ebp) new))
270 (#.esi-offset (setf (slot scp 'sc-esi) new))
271 (#.edi-offset (setf (slot scp 'sc-edi) new))))
272 new)
273
274 (defsetf sigcontext-register %set-sigcontext-register)
275
276
277 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
278 ;;;
279 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
280 ;;; Format is the type of float to return.
281 ;;; XXX
282 #-linux
283 (defun sigcontext-float-register (scp index format)
284 (declare (type (alien (* sigcontext)) scp))
285 (with-alien ((scp (* sigcontext) scp))
286 ;; fp regs not in sigcontext -- need new vop or c support
287 (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs))))
288 (declare (ignore sap))
289 index
290 (ecase format
291 (single-float 0s0
292 #+nil (system:sap-ref-single sap (* index vm:word-bytes)))
293 (double-float 0d0
294 #+nil(system:sap-ref-double sap (* index vm:word-bytes)))))))
295
296 #+linux
297 (defun sigcontext-float-register (scp index format)
298 (declare (type (alien (* sigcontext)) scp))
299 (with-alien ((scp (* sigcontext) scp))
300 ;; fp regs in sigcontext !!!
301 (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
302 'fpreg)
303 index))))
304 (ecase format
305 (single-float
306 (system:sap-ref-single reg-sap 0))
307 (double-float
308 (system:sap-ref-double reg-sap 0))))))
309
310 ;;;
311 #-linux
312 (defun %set-sigcontext-float-register (scp index format new-value)
313 (declare (type (alien (* sigcontext)) scp))
314 scp index format new-value
315 #+nil
316 (with-alien ((scp (* sigcontext) scp))
317 (let ((sap (alien-sap (slot scp 'fpregs))))
318 (ecase format
319 (single-float
320 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
321 (double-float
322 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
323 #+linux
324 (defun %set-sigcontext-float-register (scp index format new-value)
325 (declare (type (alien (* sigcontext)) scp))
326 (with-alien ((scp (* sigcontext) scp))
327 (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
328 'fpreg)
329 index))))
330 (ecase format
331 (single-float
332 (setf (system:sap-ref-single reg-sap 0) new-value))
333 (double-float
334 (setf (system:sap-ref-double reg-sap 0)new-value))))))
335
336 ;;;
337
338 (defsetf sigcontext-float-register %set-sigcontext-float-register)
339
340 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
341 ;;;
342 ;;; Given a sigcontext pointer, return the floating point modes word in the
343 ;;; same format as returned by FLOATING-POINT-MODES.
344 ;;;
345
346 #+FreeBSD
347 (defun sigcontext-floating-point-modes (scp)
348 (declare (type (alien (* sigcontext)) scp)
349 (ignore scp))
350 ;; This is broken until some future release of FreeBSD!!!
351 (floating-point-modes))
352
353 #+linux
354 (defun sigcontext-floating-point-modes (scp)
355 (declare (type (alien (* sigcontext)) scp))
356 (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
357 (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
358 ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
359 ;; NOT TESTED -- clear sticky bits to clear interrupt condition
360 (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
361 ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
362 ;; simulate floating-point-modes VOP
363 (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
364
365
366 ;;; EXTERN-ALIEN-NAME -- interface.
367 ;;;
368 ;;; The loader uses this to convert alien names to the form they occure in
369 ;;; the symbol table (for example, prepending an underscore).
370 ;;;
371 ;;; On the x86 under FreeBSD, we prepend an underscore. If this is not
372 ;;; done under Linux then this is the place to make the change.
373 ;;;
374 (defun extern-alien-name (name)
375 (declare (type simple-string name))
376 (lisp:concatenate 'string #+linux "" #-linux "_" name))
377
378 ;;; This used to live in foreign.lisp but it gets loaded too late
379 ;;; to be useful. This gets used by the loader to map lisp foreign
380 ;;; symbol names to the OS's version of it. This was added for the
381 ;;; Linux port -- maybe it makes the above extern-alien-name
382 ;;; obsolete?
383 (defun system:alternate-get-global-address(symbol)
384 (declare (type simple-string symbol))
385 (let ((namex symbol)
386 (table lisp::*foreign-symbols*)) ; defined in load.lisp
387 (cond ((gethash namex table nil))
388 #+linux ((gethash (concatenate 'string "PVE_stub_" namex) table nil))
389 #+linux ((gethash (concatenate 'string "" namex) table nil)) ; Linux
390 #+freebsd ((gethash (concatenate 'string "_" namex) table nil)); FreeBSD
391 ((gethash (concatenate 'string "__" namex) table nil))
392 ((gethash (concatenate 'string "__libc_" namex) table nil))
393 (t (progn (format t "Error: can't be in alt-get-gl-addr ~a" namex)
394 ;; returning 0 is VERY dangerous!
395 0)))))
396
397
398
399 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
400 ;;;
401 ;;; Do whatever is necessary to make the given code component executable.
402 ;;; On the sparc, we don't need to do anything, because the i and d caches
403 ;;; are unified.
404 ;;;
405 (defun sanctify-for-execution (component)
406 (declare (ignore component))
407 nil)
408
409 ;;; FLOAT-WAIT
410 ;;;
411 ;;; This is used in error.lisp to insure floating-point exceptions
412 ;;; are properly trapped. The compiler translates this to a VOP.
413 ;;; Note: if you are compiling this from an old version you may need
414 ;;; to disable this until the float-wait VOP is entrenched.
415 (defun float-wait()
416 (float-wait))
417
418 ;;; FLOAT CONSTANTS
419 ;;;
420 ;;; These are used by the FP move-from-{single|double} VOPs
421 ;;; rather than the i387 load constant instructions to avoid
422 ;;; consing in some cases.
423
424 (defvar *fp-constant-0s0* 0s0)
425 (defvar *fp-constant-0d0* 0d0)
426 (defvar *fp-constant-1s0* 1s0)
427 (defvar *fp-constant-1d0* 1d0)
428
429 ;;; Enable/Disable scavenging of the read-only space.
430 (defvar *scavenge-read-only-space*)
431
432 ;;; The current alien stack pointer; saved/restored for non-local
433 ;;; exits.
434 (defvar *alien-stack*)
435
436 ;;;
437 (defun kernel::%instance-set-conditional (object slot test-value new-value)
438 (declare (type instance object)
439 (type index slot))
440 "Atomically compare object's slot value to test-value and if EQ store
441 new-value in the slot. The original value of the slot is returned."
442 (kernel::%instance-set-conditional object slot test-value new-value))
443
444 #+complex-float
445 (progn
446 (defun complex-single-float-real (x)
447 (declare (type (complex single-float) x))
448 (the single-float (complex-single-float-real x)))
449
450 (defun complex-double-float-real (x)
451 (declare (type (complex double-float) x))
452 (the double-float (complex-double-float-real x)))
453
454 (defun complex-single-float-imag (x)
455 (declare (type (complex single-float) x))
456 (the single-float (complex-single-float-imag x)))
457
458 (defun complex-double-float-imag (x)
459 (declare (type (complex double-float) x))
460 (the double-float (complex-double-float-imag x)))
461 ) ; complex-float

  ViewVC Help
Powered by ViewVC 1.1.5