/[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.37.4.1 - (show annotations)
Sat Aug 28 00:01:23 2010 UTC (3 years, 7 months ago) by rtoy
Branch: RELEASE-20B-BRANCH
CVS Tags: release-20b-pre2, RELEASE_20b
Changes since 1.37: +39 -7 lines
code/x86-vm.lisp:
o Fix SIGCONTEXT-FLOAT-REGISTER to handle SSE2 better.  In particular,
  single-floats were incorrect for XMM registers.  Also update this to
  handle complex double-floats and complex single-floats.
o Update %SET-SIGCONTEXT-FLOAT-REGISTER to match
  SIGCONTEXT-FLOAT-REGISTER.

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

  ViewVC Help
Powered by ViewVC 1.1.5