/[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.12 - (show annotations)
Fri Jan 16 07:22:13 1998 UTC (16 years, 3 months ago) by dtc
Branch: MAIN
Changes since 1.11: +112 -59 lines
Rewrite of the x86/GENCGC purify stack scavenging to reduce the chance
of heap corruption and to try and handle return address on the stack.

Enhance new-genesis to save the code fixups for x86 code objects
allowing the code to be placed in the dynamic heap and thus garbage
collected by purify.
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.12 1998/01/16 07:22:13 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
29
30 ;;;; The sigcontext structure.
31 ;;;; Add machine specific features to *features*
32
33 (pushnew :x86 *features*)
34
35
36
37 #+linux
38 (def-alien-type nil
39 (struct fpreg
40 (significand (array unsigned-short 4))
41 (exponent unsigned-short)))
42 #+linux
43 (def-alien-type nil
44 (struct fpstate
45 (cw unsigned-long)
46 (sw unsigned-long)
47 (tag unsigned-long)
48 (ipoff unsigned-long)
49 (cssel unsigned-long)
50 (dataoff unsigned-long)
51 (datasel unsigned-long)
52 (fpreg (array (struct fpreg) 8))
53 (status unsigned-long)))
54
55 ;;; for FreeBSD
56 #+freebsd
57 (def-alien-type sigcontext
58 (struct nil
59 (sc-onstack unsigned-int)
60 (sc-mask unsigned-int)
61 (sc-sp unsigned-int)
62 (sc-fp unsigned-int)
63 (sc-isp unsigned-int)
64 (sc-pc unsigned-int)
65 (sc-efl unsigned-int) ; sc_ps
66 (sc-es unsigned-int)
67 (sc-ds unsigned-int)
68 (sc-cs unsigned-int)
69 (sc-ss unsigned-int)
70 (sc-edi unsigned-int)
71 (sc-esi unsigned-int)
72 (sc-ebx unsigned-int)
73 (sc-edx unsigned-int)
74 (sc-ecx unsigned-int)
75 (sc-eax unsigned-int)))
76
77 ;; For Linux...
78 #+linux
79 (def-alien-type sigcontext
80 (struct nil
81 (gs unsigned-short)
82 (__gsh unsigned-short)
83 (fs unsigned-short)
84 (__fsh unsigned-short)
85 (sc-es unsigned-short)
86 (__esh unsigned-short)
87 (sc-ds unsigned-short)
88 (__dsh unsigned-short)
89 (sc-edi unsigned-long)
90 (sc-esi unsigned-long)
91 (ebp unsigned-long)
92 (sc-sp unsigned-long)
93 (sc-ebx unsigned-long)
94 (sc-edx unsigned-long)
95 (sc-ecx unsigned-long)
96 (sc-eax unsigned-long)
97 (trapno unsigned-long)
98 (err unsigned-long)
99 (sc-pc unsigned-long)
100 (sc-cs unsigned-short)
101 (__csh unsigned-short)
102 (sc-efl unsigned-long)
103 (esp_at_signal unsigned-long)
104 (sc-ss unsigned-short)
105 (__ssh unsigned-short)
106 ; (fpstate unsigned-long) ;; fpstate struct pointer
107 (fpstate (* (struct fpstate)))
108 (sc-mask unsigned-long)
109 (cr2 unsigned-long)))
110
111
112
113 ;;;; MACHINE-TYPE and MACHINE-VERSION
114
115 #-cross-compiler
116 (defun machine-type ()
117 "Returns a string describing the type of the local machine."
118 "X86")
119
120
121 #-cross-compiler
122 (defun machine-version ()
123 "Returns a string describing the version of the local machine."
124 "X86")
125
126
127
128 ;;; Fixup-Code-Object -- Interface
129 ;;;
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 fixup-code-object (code offset fixup kind)
140 (declare (type index offset))
141 (flet ((add-fixup (code offset)
142 ;; Although this could check for and ignore fixups for code
143 ;; objects in the read-only and static spaces, this should
144 ;; only be the case when *enable-dynamic-space-code* is
145 ;; True.
146 (when lisp::*enable-dynamic-space-code*
147 (incf *num-fixups*)
148 (let ((fixups (code-header-ref code code-constants-offset)))
149 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
150 (let ((new-fixups
151 (adjust-array fixups (1+ (length fixups))
152 :element-type '(unsigned-byte 32))))
153 (setf (aref new-fixups (length fixups)) offset)
154 (setf (code-header-ref code code-constants-offset)
155 new-fixups)))
156 (t
157 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
158 (zerop fixups))
159 (format t "** Init. code FU = ~s~%" fixups))
160 (setf (code-header-ref code code-constants-offset)
161 (make-array 1 :element-type '(unsigned-byte 32)
162 :initial-element offset))))))))
163 (system:without-gcing
164 (let* ((sap (truly-the system-area-pointer
165 (kernel: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 (sys: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
186 ;; object.
187 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
188 (add-fixup code offset))
189 ;; Replace word with value to add to that loc to get there.
190 (let* ((loc-sap (+ (sap-int sap) offset))
191 (rel-val (- fixup loc-sap 4)))
192 (declare (type (unsigned-byte 32) loc-sap)
193 (type (signed-byte 32) rel-val))
194 (setf (signed-sap-ref-32 sap offset) rel-val))))))
195 nil))
196
197 ;;; Do-Load-Time-Code-Fixups
198 ;;;
199 ;;; Add a code fixup to a code object generated by new-genesis. The
200 ;;; fixup has already been applied, it's just a matter of placing the
201 ;;; fixup in the code's fixup vector if necessary.
202 ;;;
203 #+gencgc
204 (defun do-load-time-code-fixup (code offset fixup kind)
205 (flet ((add-load-time-code-fixup (code offset)
206 (let ((fixups (code-header-ref code vm:code-constants-offset)))
207 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
208 (let ((new-fixups
209 (adjust-array fixups (1+ (length fixups))
210 :element-type '(unsigned-byte 32))))
211 (setf (aref new-fixups (length fixups)) offset)
212 (setf (code-header-ref code vm:code-constants-offset)
213 new-fixups)))
214 (t
215 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
216 (zerop fixups))
217 (%primitive print "** Init. code FU"))
218 (setf (code-header-ref code vm:code-constants-offset)
219 (make-array 1 :element-type '(unsigned-byte 32)
220 :initial-element offset)))))))
221 (let* ((sap (truly-the system-area-pointer
222 (kernel:code-instructions code)))
223 (obj-start-addr
224 (logand (kernel:get-lisp-obj-address code) #xfffffff8))
225 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
226 (ncode-words (kernel:code-header-ref code 1))
227 (code-end-addr (+ code-start-addr (* ncode-words 4))))
228 (ecase kind
229 (:absolute
230 ;; Record absolute fixups that point within the
231 ;; code object.
232 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
233 (add-load-time-code-fixup code offset)))
234 (:relative
235 ;; Record relative fixups that point outside the
236 ;; code object.
237 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
238 (add-load-time-code-fixup code offset)))))))
239
240
241 ;;;; Internal-error-arguments.
242
243 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
244 ;;;
245 ;;; Given the sigcontext, extract the internal error arguments from the
246 ;;; instruction stream.
247 ;;;
248 (defun internal-error-arguments (scp)
249 (declare (type (alien (* sigcontext)) scp))
250 (with-alien ((scp (* sigcontext) scp))
251 (let ((pc (int-sap (slot scp 'sc-pc))))
252 (declare (type system-area-pointer pc))
253 ;; using INT3 the pc is .. INT3 <here> code length bytes...
254 (let* ((length (sap-ref-8 pc 1))
255 (vector (make-array length :element-type '(unsigned-byte 8))))
256 (declare (type (unsigned-byte 8) length)
257 (type (simple-array (unsigned-byte 8) (*)) vector))
258 (copy-from-system-area pc (* vm:byte-bits 2)
259 vector (* vm:word-bits
260 vm:vector-data-offset)
261 (* length vm:byte-bits))
262 (let* ((index 0)
263 (error-number (c::read-var-integer vector index)))
264 (collect ((sc-offsets))
265 (loop
266 (when (>= index length)
267 (return))
268 (sc-offsets (c::read-var-integer vector index)))
269 (values error-number (sc-offsets))))))))
270
271
272 ;;;; Sigcontext access functions.
273
274 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
275 ;;;
276 (defun sigcontext-program-counter (scp)
277 (declare (type (alien (* sigcontext)) scp))
278 (with-alien ((scp (* sigcontext) scp))
279 (int-sap (slot scp 'sc-pc))))
280
281 ;;; SIGCONTEXT-REGISTER -- Interface.
282 ;;;
283 ;;; An escape register saves the value of a register for a frame that someone
284 ;;; interrupts.
285 ;;;
286
287 (defun sigcontext-register (scp index)
288 (declare (type (alien (* sigcontext)) scp))
289 (with-alien ((scp (* sigcontext) scp))
290 (case index ; ugly -- I know.
291 (#.eax-offset (slot scp 'sc-eax))
292 (#.ecx-offset (slot scp 'sc-ecx))
293 (#.edx-offset (slot scp 'sc-edx))
294 (#.ebx-offset (slot scp 'sc-ebx))
295 (#.esp-offset (slot scp 'sc-sp))
296 #-linux (#.ebp-offset (slot scp 'sc-fp))
297 #+linux (#.ebp-offset (slot scp 'ebp))
298 (#.esi-offset (slot scp 'sc-esi))
299 (#.edi-offset (slot scp 'sc-edi)))))
300
301
302 (defun %set-sigcontext-register (scp index new)
303 (declare (type (alien (* sigcontext)) scp))
304 (with-alien ((scp (* sigcontext) scp))
305 (case index
306 (#.eax-offset (setf (slot scp 'sc-eax) new))
307 (#.ecx-offset (setf (slot scp 'sc-ecx) new))
308 (#.edx-offset (setf (slot scp 'sc-edx) new))
309 (#.ebx-offset (setf (slot scp 'sc-ebx) new))
310 (#.esp-offset (setf (slot scp 'sc-sp) new))
311 #-linux (#.ebp-offset (setf (slot scp 'sc-fp) new))
312 #+linux (#.ebp-offset (setf (slot scp 'ebp) new))
313 (#.esi-offset (setf (slot scp 'sc-esi) new))
314 (#.edi-offset (setf (slot scp 'sc-edi) new))))
315 new)
316
317 (defsetf sigcontext-register %set-sigcontext-register)
318
319
320 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
321 ;;;
322 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
323 ;;; Format is the type of float to return.
324 ;;; XXX
325 #-linux
326 (defun sigcontext-float-register (scp index format)
327 (declare (type (alien (* sigcontext)) scp))
328 (with-alien ((scp (* sigcontext) scp))
329 ;; fp regs not in sigcontext -- need new vop or c support
330 (let ((sap #+nil (alien-sap (slot scp 'sc-fpregs))))
331 (declare (ignore sap))
332 index
333 (ecase format
334 (single-float 0s0
335 #+nil (system:sap-ref-single sap (* index vm:word-bytes)))
336 (double-float 0d0
337 #+nil(system:sap-ref-double sap (* index vm:word-bytes)))))))
338
339 #+linux
340 (defun sigcontext-float-register (scp index format)
341 (declare (type (alien (* sigcontext)) scp))
342 (with-alien ((scp (* sigcontext) scp))
343 ;; fp regs in sigcontext !!!
344 (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
345 'fpreg)
346 index))))
347 (ecase format
348 (single-float
349 (system:sap-ref-single reg-sap 0))
350 (double-float
351 (system:sap-ref-double reg-sap 0))))))
352
353 ;;;
354 #-linux
355 (defun %set-sigcontext-float-register (scp index format new-value)
356 (declare (type (alien (* sigcontext)) scp))
357 scp index format new-value
358 #+nil
359 (with-alien ((scp (* sigcontext) scp))
360 (let ((sap (alien-sap (slot scp 'fpregs))))
361 (ecase format
362 (single-float
363 (setf (sap-ref-single sap (* index vm:word-bytes)) new-value))
364 (double-float
365 (setf (sap-ref-double sap (* index vm:word-bytes)) new-value))))))
366 #+linux
367 (defun %set-sigcontext-float-register (scp index format new-value)
368 (declare (type (alien (* sigcontext)) scp))
369 (with-alien ((scp (* sigcontext) scp))
370 (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
371 'fpreg)
372 index))))
373 (ecase format
374 (single-float
375 (setf (system:sap-ref-single reg-sap 0) new-value))
376 (double-float
377 (setf (system:sap-ref-double reg-sap 0)new-value))))))
378
379 ;;;
380
381 (defsetf sigcontext-float-register %set-sigcontext-float-register)
382
383 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
384 ;;;
385 ;;; Given a sigcontext pointer, return the floating point modes word in the
386 ;;; same format as returned by FLOATING-POINT-MODES.
387 ;;;
388
389 #+FreeBSD
390 (defun sigcontext-floating-point-modes (scp)
391 (declare (type (alien (* sigcontext)) scp)
392 (ignore scp))
393 ;; This is broken until some future release of FreeBSD!!!
394 (floating-point-modes))
395
396 #+linux
397 (defun sigcontext-floating-point-modes (scp)
398 (declare (type (alien (* sigcontext)) scp))
399 (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
400 (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
401 ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
402 ;; NOT TESTED -- clear sticky bits to clear interrupt condition
403 (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
404 ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
405 ;; simulate floating-point-modes VOP
406 (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
407
408
409 ;;; EXTERN-ALIEN-NAME -- interface.
410 ;;;
411 ;;; The loader uses this to convert alien names to the form they occure in
412 ;;; the symbol table (for example, prepending an underscore).
413 ;;;
414 (defun extern-alien-name (name)
415 (declare (type simple-string name))
416 name)
417
418 (defun lisp::foreign-symbol-address-aux (name)
419 (multiple-value-bind (value found)
420 (gethash name lisp::*foreign-symbols* 0)
421 (if found
422 value
423 (multiple-value-bind (value found)
424 (gethash
425 (concatenate 'string #+linux "PVE_stub_" #+freebsd "_" name)
426 lisp::*foreign-symbols* 0)
427 (if found
428 value
429 (let ((value (system:alternate-get-global-address name)))
430 (when (zerop value)
431 (error "Unknown foreign symbol: ~S" name))
432 value))))))
433
434
435 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
436 ;;;
437 ;;; Do whatever is necessary to make the given code component executable.
438 ;;; On the sparc, we don't need to do anything, because the i and d caches
439 ;;; are unified.
440 ;;;
441 (defun sanctify-for-execution (component)
442 (declare (ignore component))
443 nil)
444
445 ;;; FLOAT-WAIT
446 ;;;
447 ;;; This is used in error.lisp to insure floating-point exceptions
448 ;;; are properly trapped. The compiler translates this to a VOP.
449 ;;; Note: if you are compiling this from an old version you may need
450 ;;; to disable this until the float-wait VOP is entrenched.
451 (defun float-wait()
452 (float-wait))
453
454 ;;; FLOAT CONSTANTS
455 ;;;
456 ;;; These are used by the FP move-from-{single|double} VOPs
457 ;;; rather than the i387 load constant instructions to avoid
458 ;;; consing in some cases.
459
460 (defvar *fp-constant-0s0* 0s0)
461 (defvar *fp-constant-0d0* 0d0)
462 (defvar *fp-constant-1s0* 1s0)
463 (defvar *fp-constant-1d0* 1d0)
464
465 ;;; Enable/Disable scavenging of the read-only space.
466 (defvar *scavenge-read-only-space* nil)
467
468 ;;; The current alien stack pointer; saved/restored for non-local
469 ;;; exits.
470 (defvar *alien-stack*)
471
472 ;;;
473 (defun kernel::%instance-set-conditional (object slot test-value new-value)
474 (declare (type instance object)
475 (type index slot))
476 "Atomically compare object's slot value to test-value and if EQ store
477 new-value in the slot. The original value of the slot is returned."
478 (kernel::%instance-set-conditional object slot test-value new-value))
479
480 ;;; Support for the MT19937 random number generator. The update
481 ;;; function is implemented as an assembly routine. This definition is
482 ;;; transformed to a call to this routine allowing its use in byte
483 ;;; compiled code.
484 ;;;
485 (defun random-mt19937 (state)
486 (declare (type (simple-array (unsigned-byte 32) (627)) state))
487 (random-mt19937 state))

  ViewVC Help
Powered by ViewVC 1.1.5