/[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.15 - (show annotations)
Fri Mar 26 15:57:00 1999 UTC (15 years, 1 month ago) by dtc
Branch: MAIN
Changes since 1.14: +113 -9 lines
New functions are macros to support thread safe code:
set-symbol-value-conditional, rplaca-conditional,
rplacd-conditional, data-vector-set-conditional,
atomic-push-symbol-value, atomic-pop-symbol-value, atomic-pusha,
atomic-pushd atomic-push-vector.
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.15 1999/03/26 15:57:00 dtc Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; This file contains the X86 specific runtime stuff.
15 ;;;
16 ;;; Code movement fixups by Douglas T. Crosher, 1997.
17 ;;; Thread support by Douglas T. Crosher, 1999.
18 ;;;
19
20 (in-package "X86")
21 (use-package "SYSTEM")
22 (use-package "ALIEN")
23 (use-package "C-CALL")
24 (use-package "UNIX")
25 (use-package "KERNEL")
26
27 (export '(fixup-code-object internal-error-arguments
28 sigcontext-program-counter sigcontext-register
29 sigcontext-float-register sigcontext-floating-point-modes
30 extern-alien-name sanctify-for-execution))
31
32
33 ;;;; The sigcontext structure.
34 ;;;; Add machine specific features to *features*
35
36 (pushnew :x86 *features*)
37
38
39
40 #+linux
41 (def-alien-type nil
42 (struct fpreg
43 (significand (array unsigned-short 4))
44 (exponent unsigned-short)))
45 #+linux
46 (def-alien-type nil
47 (struct fpstate
48 (cw unsigned-long)
49 (sw unsigned-long)
50 (tag unsigned-long)
51 (ipoff unsigned-long)
52 (cssel unsigned-long)
53 (dataoff unsigned-long)
54 (datasel unsigned-long)
55 (fpreg (array (struct fpreg) 8))
56 (status unsigned-long)))
57
58 ;;; for FreeBSD
59 #+freebsd
60 (def-alien-type sigcontext
61 (struct nil
62 (sc-onstack unsigned-int)
63 (sc-mask unsigned-int)
64 (sc-sp unsigned-int)
65 (sc-fp unsigned-int)
66 (sc-isp unsigned-int)
67 (sc-pc unsigned-int)
68 (sc-efl unsigned-int) ; sc_ps
69 (sc-es unsigned-int)
70 (sc-ds unsigned-int)
71 (sc-cs unsigned-int)
72 (sc-ss unsigned-int)
73 (sc-edi unsigned-int)
74 (sc-esi unsigned-int)
75 (sc-ebx unsigned-int)
76 (sc-edx unsigned-int)
77 (sc-ecx unsigned-int)
78 (sc-eax unsigned-int)))
79
80 ;; For Linux...
81 #+linux
82 (def-alien-type sigcontext
83 (struct nil
84 (gs unsigned-short)
85 (__gsh unsigned-short)
86 (fs unsigned-short)
87 (__fsh unsigned-short)
88 (sc-es unsigned-short)
89 (__esh unsigned-short)
90 (sc-ds unsigned-short)
91 (__dsh unsigned-short)
92 (sc-edi unsigned-long)
93 (sc-esi unsigned-long)
94 (ebp unsigned-long)
95 (sc-sp unsigned-long)
96 (sc-ebx unsigned-long)
97 (sc-edx unsigned-long)
98 (sc-ecx unsigned-long)
99 (sc-eax unsigned-long)
100 (trapno unsigned-long)
101 (err unsigned-long)
102 (sc-pc unsigned-long)
103 (sc-cs unsigned-short)
104 (__csh unsigned-short)
105 (sc-efl unsigned-long)
106 (esp_at_signal unsigned-long)
107 (sc-ss unsigned-short)
108 (__ssh unsigned-short)
109 ; (fpstate unsigned-long) ;; fpstate struct pointer
110 (fpstate (* (struct fpstate)))
111 (sc-mask unsigned-long)
112 (cr2 unsigned-long)))
113
114
115
116 ;;;; MACHINE-TYPE and MACHINE-VERSION
117
118 #-cross-compiler
119 (defun machine-type ()
120 "Returns a string describing the type of the local machine."
121 "X86")
122
123
124 #-cross-compiler
125 (defun machine-version ()
126 "Returns a string describing the version of the local machine."
127 "X86")
128
129
130
131 ;;; Fixup-Code-Object -- Interface
132 ;;;
133 ;;; This gets called by LOAD to resolve newly positioned objects
134 ;;; with things (like code instructions) that have to refer to them.
135 ;;;
136 ;;; Add a fixup offset to the vector of fixup offsets for the given
137 ;;; code object.
138 ;;;
139 ;;; Counter to measure the storage overhead.
140 (defvar *num-fixups* 0)
141 ;;;
142 (defun fixup-code-object (code offset fixup kind)
143 (declare (type index offset))
144 (flet ((add-fixup (code offset)
145 ;; Although this could check for and ignore fixups for code
146 ;; objects in the read-only and static spaces, this should
147 ;; only be the case when *enable-dynamic-space-code* is
148 ;; True.
149 (when lisp::*enable-dynamic-space-code*
150 (incf *num-fixups*)
151 (let ((fixups (code-header-ref code code-constants-offset)))
152 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
153 (let ((new-fixups
154 (adjust-array fixups (1+ (length fixups))
155 :element-type '(unsigned-byte 32))))
156 (setf (aref new-fixups (length fixups)) offset)
157 (setf (code-header-ref code code-constants-offset)
158 new-fixups)))
159 (t
160 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
161 (zerop fixups))
162 (format t "** Init. code FU = ~s~%" fixups))
163 (setf (code-header-ref code code-constants-offset)
164 (make-array 1 :element-type '(unsigned-byte 32)
165 :initial-element offset))))))))
166 (system:without-gcing
167 (let* ((sap (truly-the system-area-pointer
168 (kernel:code-instructions code)))
169 (obj-start-addr (logand (kernel:get-lisp-obj-address code)
170 #xfffffff8))
171 #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
172 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
173 (ncode-words (kernel:code-header-ref code 1))
174 (code-end-addr (+ code-start-addr (* ncode-words 4))))
175 (unless (member kind '(:absolute :relative))
176 (error "Unknown code-object-fixup kind ~s." kind))
177 (ecase kind
178 (:absolute
179 ;; Word at sap + offset contains a value to be replaced by
180 ;; adding that value to fixup.
181 (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
182 ;; Record absolute fixups that point within the code object.
183 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
184 (add-fixup code offset)))
185 (:relative
186 ;; Fixup is the actual address wanted.
187 ;;
188 ;; Record relative fixups that point outside the code
189 ;; object.
190 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
191 (add-fixup code offset))
192 ;; Replace word with value to add to that loc to get there.
193 (let* ((loc-sap (+ (sap-int sap) offset))
194 (rel-val (- fixup loc-sap 4)))
195 (declare (type (unsigned-byte 32) loc-sap)
196 (type (signed-byte 32) rel-val))
197 (setf (signed-sap-ref-32 sap offset) rel-val))))))
198 nil))
199
200 ;;; Do-Load-Time-Code-Fixups
201 ;;;
202 ;;; Add a code fixup to a code object generated by new-genesis. The
203 ;;; fixup has already been applied, it's just a matter of placing the
204 ;;; fixup in the code's fixup vector if necessary.
205 ;;;
206 #+gencgc
207 (defun do-load-time-code-fixup (code offset fixup kind)
208 (flet ((add-load-time-code-fixup (code offset)
209 (let ((fixups (code-header-ref code vm:code-constants-offset)))
210 (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
211 (let ((new-fixups
212 (adjust-array fixups (1+ (length fixups))
213 :element-type '(unsigned-byte 32))))
214 (setf (aref new-fixups (length fixups)) offset)
215 (setf (code-header-ref code vm:code-constants-offset)
216 new-fixups)))
217 (t
218 (unless (or (eq (get-type fixups) vm:unbound-marker-type)
219 (zerop fixups))
220 (%primitive print "** Init. code FU"))
221 (setf (code-header-ref code vm:code-constants-offset)
222 (make-array 1 :element-type '(unsigned-byte 32)
223 :initial-element offset)))))))
224 (let* ((sap (truly-the system-area-pointer
225 (kernel:code-instructions code)))
226 (obj-start-addr
227 (logand (kernel:get-lisp-obj-address code) #xfffffff8))
228 (code-start-addr (sys:sap-int (kernel:code-instructions code)))
229 (ncode-words (kernel:code-header-ref code 1))
230 (code-end-addr (+ code-start-addr (* ncode-words 4))))
231 (ecase kind
232 (:absolute
233 ;; Record absolute fixups that point within the
234 ;; code object.
235 (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
236 (add-load-time-code-fixup code offset)))
237 (:relative
238 ;; Record relative fixups that point outside the
239 ;; code object.
240 (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
241 (add-load-time-code-fixup code offset)))))))
242
243
244 ;;;; Internal-error-arguments.
245
246 ;;; INTERNAL-ERROR-ARGUMENTS -- interface.
247 ;;;
248 ;;; Given the sigcontext, extract the internal error arguments from the
249 ;;; instruction stream.
250 ;;;
251 (defun internal-error-arguments (scp)
252 (declare (type (alien (* sigcontext)) scp))
253 (with-alien ((scp (* sigcontext) scp))
254 (let ((pc (int-sap (slot scp 'sc-pc))))
255 (declare (type system-area-pointer pc))
256 ;; using INT3 the pc is .. INT3 <here> code length bytes...
257 (let* ((length (sap-ref-8 pc 1))
258 (vector (make-array length :element-type '(unsigned-byte 8))))
259 (declare (type (unsigned-byte 8) length)
260 (type (simple-array (unsigned-byte 8) (*)) vector))
261 (copy-from-system-area pc (* vm:byte-bits 2)
262 vector (* vm:word-bits
263 vm:vector-data-offset)
264 (* length vm:byte-bits))
265 (let* ((index 0)
266 (error-number (c::read-var-integer vector index)))
267 (collect ((sc-offsets))
268 (loop
269 (when (>= index length)
270 (return))
271 (sc-offsets (c::read-var-integer vector index)))
272 (values error-number (sc-offsets))))))))
273
274
275 ;;;; Sigcontext access functions.
276
277 ;;; SIGCONTEXT-PROGRAM-COUNTER -- Interface.
278 ;;;
279 (defun sigcontext-program-counter (scp)
280 (declare (type (alien (* sigcontext)) scp))
281 (with-alien ((scp (* sigcontext) scp))
282 (int-sap (slot scp 'sc-pc))))
283
284 ;;; SIGCONTEXT-REGISTER -- Interface.
285 ;;;
286 ;;; An escape register saves the value of a register for a frame that someone
287 ;;; interrupts.
288 ;;;
289
290 (defun sigcontext-register (scp index)
291 (declare (type (alien (* sigcontext)) scp))
292 (with-alien ((scp (* sigcontext) scp))
293 (case index ; ugly -- I know.
294 (#.eax-offset (slot scp 'sc-eax))
295 (#.ecx-offset (slot scp 'sc-ecx))
296 (#.edx-offset (slot scp 'sc-edx))
297 (#.ebx-offset (slot scp 'sc-ebx))
298 (#.esp-offset (slot scp 'sc-sp))
299 (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
300 (#.esi-offset (slot scp 'sc-esi))
301 (#.edi-offset (slot scp 'sc-edi)))))
302
303
304 (defun %set-sigcontext-register (scp index new)
305 (declare (type (alien (* sigcontext)) scp))
306 (with-alien ((scp (* sigcontext) scp))
307 (case index
308 (#.eax-offset (setf (slot scp 'sc-eax) new))
309 (#.ecx-offset (setf (slot scp 'sc-ecx) new))
310 (#.edx-offset (setf (slot scp 'sc-edx) new))
311 (#.ebx-offset (setf (slot scp 'sc-ebx) new))
312 (#.esp-offset (setf (slot scp 'sc-sp) new))
313 (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
314 (#.esi-offset (setf (slot scp 'sc-esi) new))
315 (#.edi-offset (setf (slot scp 'sc-edi) new))))
316 new)
317
318 (defsetf sigcontext-register %set-sigcontext-register)
319
320
321 ;;; SIGCONTEXT-FLOAT-REGISTER -- Interface
322 ;;;
323 ;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
324 ;;; Format is the type of float to return.
325 ;;;
326 #+linux
327 (defun sigcontext-float-register (scp index format)
328 (declare (type (alien (* sigcontext)) scp))
329 (with-alien ((scp (* sigcontext) scp))
330 (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
331 'fpreg)
332 index))))
333 (coerce (sys:sap-ref-long reg-sap 0) format))))
334
335 ;;; Not supported on FreeBSD because the floating point state is not
336 ;;; saved.
337 #+FreeBSD
338 (defun sigcontext-float-register (scp index format)
339 (declare (ignore scp index))
340 (coerce 0l0 format))
341
342 #+linux
343 (defun %set-sigcontext-float-register (scp index format new-value)
344 (declare (type (alien (* sigcontext)) scp))
345 (with-alien ((scp (* sigcontext) scp))
346 (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
347 'fpreg)
348 index))))
349 (declare (ignorable reg-sap))
350 #+not-yet
351 (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
352 (coerce new-value format))))
353
354 ;;; Not supported on FreeBSD.
355 #+FreeBSD
356 (defun %set-sigcontext-float-register (scp index format new-value)
357 (declare (ignore scp index))
358 (coerce new-value format))
359
360 ;;;
361 (defsetf sigcontext-float-register %set-sigcontext-float-register)
362
363 ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
364 ;;;
365 ;;; Given a sigcontext pointer, return the floating point modes word in the
366 ;;; same format as returned by FLOATING-POINT-MODES.
367 ;;;
368
369 #+FreeBSD
370 (defun sigcontext-floating-point-modes (scp)
371 (declare (type (alien (* sigcontext)) scp)
372 (ignore scp))
373 ;; This is broken until some future release of FreeBSD!!!
374 (floating-point-modes))
375
376 #+linux
377 (defun sigcontext-floating-point-modes (scp)
378 (declare (type (alien (* sigcontext)) scp))
379 (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
380 (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
381 ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
382 ;; NOT TESTED -- clear sticky bits to clear interrupt condition
383 (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
384 ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
385 ;; simulate floating-point-modes VOP
386 (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
387
388
389 ;;; EXTERN-ALIEN-NAME -- interface.
390 ;;;
391 ;;; The loader uses this to convert alien names to the form they occure in
392 ;;; the symbol table (for example, prepending an underscore).
393 ;;;
394 (defun extern-alien-name (name)
395 (declare (type simple-string name))
396 name)
397
398 (defun lisp::foreign-symbol-address-aux (name)
399 (multiple-value-bind (value found)
400 (gethash name lisp::*foreign-symbols* 0)
401 (if found
402 value
403 (multiple-value-bind (value found)
404 (gethash
405 (concatenate 'string #+linux "PVE_stub_" #+freebsd "_" name)
406 lisp::*foreign-symbols* 0)
407 (if found
408 value
409 (let ((value (system:alternate-get-global-address name)))
410 (when (zerop value)
411 (error "Unknown foreign symbol: ~S" name))
412 value))))))
413
414
415 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
416 ;;;
417 ;;; Do whatever is necessary to make the given code component
418 ;;; executable - nothing on the x86.
419 ;;;
420 (defun sanctify-for-execution (component)
421 (declare (ignore component))
422 nil)
423
424 ;;; FLOAT-WAIT
425 ;;;
426 ;;; This is used in error.lisp to insure floating-point exceptions
427 ;;; are properly trapped. The compiler translates this to a VOP.
428 ;;;
429 (defun float-wait()
430 (float-wait))
431
432 ;;; FLOAT CONSTANTS
433 ;;;
434 ;;; These are used by the FP move-from-{single|double} VOPs rather
435 ;;; than the i387 load constant instructions to avoid consing in some
436 ;;; cases. Note these are initialise by genesis as they are needed
437 ;;; early.
438 ;;;
439 (defvar *fp-constant-0s0*)
440 (defvar *fp-constant-1s0*)
441 (defvar *fp-constant-0d0*)
442 (defvar *fp-constant-1d0*)
443 ;;; The long-float constants.
444 (defvar *fp-constant-0l0*)
445 (defvar *fp-constant-1l0*)
446 (defvar *fp-constant-pi*)
447 (defvar *fp-constant-l2t*)
448 (defvar *fp-constant-l2e*)
449 (defvar *fp-constant-lg2*)
450 (defvar *fp-constant-ln2*)
451
452 ;;; Enable/Disable scavenging of the read-only space.
453 (defvar *scavenge-read-only-space* nil)
454
455 ;;; The current alien stack pointer; saved/restored for non-local
456 ;;; exits.
457 (defvar *alien-stack*)
458
459 ;;; Support for the MT19937 random number generator. The update
460 ;;; function is implemented as an assembly routine. This definition is
461 ;;; transformed to a call to this routine allowing its use in byte
462 ;;; compiled code.
463 ;;;
464 (defun random-mt19937 (state)
465 (declare (type (simple-array (unsigned-byte 32) (627)) state))
466 (random-mt19937 state))
467
468
469 ;;;; Useful definitions for writing thread safe code.
470
471 (in-package "KERNEL")
472
473 (export '(atomic-push-symbol-value atomic-pop-symbol-value
474 atomic-pusha atomic-pushd atomic-push-vector))
475
476 (defun %instance-set-conditional (object slot test-value new-value)
477 (declare (type instance object)
478 (type index slot))
479 "Atomically compare object's slot value to test-value and if EQ store
480 new-value in the slot. The original value of the slot is returned."
481 (%instance-set-conditional object slot test-value new-value))
482
483 (defun set-symbol-value-conditional (symbol test-value new-value)
484 (declare (type symbol symbol))
485 "Atomically compare symbol's value to test-value and if EQ store
486 new-value in symbol's value slot and return the original value."
487 (set-symbol-value-conditional symbol test-value new-value))
488
489 (defun rplaca-conditional (cons test-value new-value)
490 (declare (type cons cons))
491 "Atomically compare the car of CONS to test-value and if EQ store
492 new-value its car and return the original value."
493 (rplaca-conditional cons test-value new-value))
494
495 (defun rplacd-conditional (cons test-value new-value)
496 (declare (type cons cons))
497 "Atomically compare the cdr of CONS to test-value and if EQ store
498 new-value its cdr and return the original value."
499 (rplacd-conditional cons test-value new-value))
500
501 (defun data-vector-set-conditional (vector index test-value new-value)
502 (declare (type simple-vector vector))
503 "Atomically compare an element of vector to test-value and if EQ store
504 new-value the element and return the original value."
505 (data-vector-set-conditional vector index test-value new-value))
506
507 (defmacro atomic-push-symbol-value (val symbol)
508 "Thread safe push of val onto the list in the symbol global value."
509 (ext:once-only ((n-val val))
510 (let ((new-list (gensym))
511 (old-list (gensym)))
512 `(let ((,new-list (cons ,n-val nil)))
513 (loop
514 (let ((,old-list ,symbol))
515 (setf (cdr ,new-list) ,old-list)
516 (when (eq (set-symbol-value-conditional
517 ',symbol ,old-list ,new-list)
518 ,old-list)
519 (return ,new-list))))))))
520
521 (defmacro atomic-pop-symbol-value (symbol)
522 "Thread safe pop from the list in the symbol global value."
523 (let ((new-list (gensym))
524 (old-list (gensym)))
525 `(loop
526 (let* ((,old-list ,symbol)
527 (,new-list (cdr ,old-list)))
528 (when (eq (set-symbol-value-conditional
529 ',symbol ,old-list ,new-list)
530 ,old-list)
531 (return (car ,old-list)))))))
532
533 (defmacro atomic-pusha (val cons)
534 "Thread safe push of val onto the list in the car of cons."
535 (once-only ((n-val val)
536 (n-cons cons))
537 (let ((new-list (gensym))
538 (old-list (gensym)))
539 `(let ((,new-list (cons ,n-val nil)))
540 (loop
541 (let ((,old-list (car ,n-cons)))
542 (setf (cdr ,new-list) ,old-list)
543 (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
544 ,old-list)
545 (return ,new-list))))))))
546
547 (defmacro atomic-pushd (val cons)
548 "Thread safe push of val onto the list in the cdr of cons."
549 (once-only ((n-val val)
550 (n-cons cons))
551 (let ((new-list (gensym))
552 (old-list (gensym)))
553 `(let ((,new-list (cons ,n-val nil)))
554 (loop
555 (let ((,old-list (cdr ,n-cons)))
556 (setf (cdr ,new-list) ,old-list)
557 (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
558 ,old-list)
559 (return ,new-list))))))))
560
561 (defmacro atomic-push-vector (val vect index)
562 "Thread safe push of val onto the list in the vector element."
563 (once-only ((n-val val)
564 (n-vect vect)
565 (n-index index))
566 (let ((new-list (gensym))
567 (old-list (gensym)))
568 `(let ((,new-list (cons ,n-val nil)))
569 (loop
570 (let ((,old-list (svref ,n-vect ,n-index)))
571 (setf (cdr ,new-list) ,old-list)
572 (when (eq (data-vector-set-conditional
573 ,n-vect ,n-index ,old-list ,new-list)
574 ,old-list)
575 (return ,new-list))))))))

  ViewVC Help
Powered by ViewVC 1.1.5