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

  ViewVC Help
Powered by ViewVC 1.1.5