/[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.32.2.4 - (hide annotations)
Fri Feb 26 15:32:49 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-2010-03-18-1300
Changes since 1.32.2.3: +2 -2 lines
Put these files in their own domain since they are only compiled on the
appropriate architecture and OS.
1 ram 1.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 dtc 1.7 (ext:file-comment
10 rtoy 1.32.2.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.32.2.4 2010/02/26 15:32:49 rtoy Exp $")
11 ram 1.1 ;;;
12     ;;; **********************************************************************
13     ;;;
14     ;;; This file contains the X86 specific runtime stuff.
15     ;;;
16 dtc 1.15 ;;; Code movement fixups by Douglas T. Crosher, 1997.
17     ;;; Thread support by Douglas T. Crosher, 1999.
18     ;;;
19 ram 1.1
20 dtc 1.7 (in-package "X86")
21 ram 1.1 (use-package "SYSTEM")
22     (use-package "ALIEN")
23     (use-package "C-CALL")
24     (use-package "UNIX")
25 dtc 1.7 (use-package "KERNEL")
26 ram 1.1
27 rtoy 1.32.2.4 (intl:textdomain "cmucl-x86-vm")
28 rtoy 1.32.2.1
29 ram 1.1 (export '(fixup-code-object internal-error-arguments
30     sigcontext-program-counter sigcontext-register
31     sigcontext-float-register sigcontext-floating-point-modes
32 dtc 1.9 extern-alien-name sanctify-for-execution))
33 ram 1.1
34 rtoy 1.30 #+complex-fp-vops
35     (sys:register-lisp-feature :complex-fp-vops)
36    
37     #+(or x87 (not :sse2))
38     (sys:register-lisp-feature :x87)
39 agoncharov 1.31 #+sse2
40     (progn
41     (setf *features* (delete :x87 *features*))
42 rtoy 1.32 (sys:register-lisp-feature :sse2))
43 rtoy 1.30
44 ram 1.1
45     ;;;; The sigcontext structure.
46 cshapiro 1.29
47     (def-alien-type sigcontext system-area-pointer)
48    
49 ram 1.1 ;;;; 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 rtoy 1.32.2.2 _N"Returns a string describing the type of the local machine."
59 ram 1.1 "X86")
60    
61    
62     #-cross-compiler
63     (defun machine-version ()
64 rtoy 1.32.2.2 _N"Returns a string describing the version of the local machine."
65 ram 1.1 "X86")
66    
67    
68    
69 dtc 1.12 ;;; Fixup-Code-Object -- Interface
70     ;;;
71 ram 1.1 ;;; This gets called by LOAD to resolve newly positioned objects
72     ;;; with things (like code instructions) that have to refer to them.
73 dtc 1.12 ;;;
74 dtc 1.7 ;;; 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 moore 1.21 ;;; XXX
80 ram 1.1 (defun fixup-code-object (code offset fixup kind)
81     (declare (type index offset))
82 dtc 1.12 (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 rtoy 1.32.2.3 (error _"Unknown code-object-fixup kind ~s." kind))
115 dtc 1.12 (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 ram 1.1
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 cshapiro 1.27 (let ((pc (sigcontext-program-counter scp)))
193 ram 1.1 (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 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_pc"
220     (function system-area-pointer
221     (* sigcontext)))))
222     (sap-ref-sap (alien-funcall fn scp) 0)))
223 rtoy 1.22
224 ram 1.1 ;;; 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 cshapiro 1.29 (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 ram 1.1
237     (defun %set-sigcontext-register (scp index new)
238     (declare (type (alien (* sigcontext)) scp))
239 cshapiro 1.29 (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 rtoy 1.22
245 ram 1.1 (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 register.
251     ;;; Format is the type of float to return.
252 dtc 1.13 ;;;
253 ram 1.1 (defun sigcontext-float-register (scp index format)
254     (declare (type (alien (* sigcontext)) scp))
255 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_reg"
256     (function system-area-pointer
257     (* sigcontext)
258     (integer 32)))))
259     (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)))
260     ;;;
261     (defun %set-sigcontext-float-register (scp index format new)
262 ram 1.1 (declare (type (alien (* sigcontext)) scp))
263 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_reg"
264     (function system-area-pointer
265     (* sigcontext)
266     (integer 32)))))
267     (let* ((sap (alien-funcall fn scp index))
268     (result (setf (sap-ref-long sap 0) (coerce new 'long-float))))
269     (coerce result format))))
270 ram 1.1 ;;;
271     (defsetf sigcontext-float-register %set-sigcontext-float-register)
272    
273     ;;; SIGCONTEXT-FLOATING-POINT-MODES -- Interface
274     ;;;
275     ;;; Given a sigcontext pointer, return the floating point modes word in the
276     ;;; same format as returned by FLOATING-POINT-MODES.
277     ;;;
278     (defun sigcontext-floating-point-modes (scp)
279     (declare (type (alien (* sigcontext)) scp))
280 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_modes"
281     (function (integer 32)
282     (* sigcontext)))))
283     (alien-funcall fn scp)))
284 ram 1.1
285 rtoy 1.30 (defun %set-sigcontext-floating-point-modes (scp new-mode)
286     (declare (type (alien (* sigcontext)) scp))
287     (let ((fn (extern-alien "os_set_sigcontext_fpu_modes"
288     (function (integer 32)
289     (* sigcontext)
290     c-call:unsigned-int))))
291     (alien-funcall fn scp new-mode)
292     new-mode))
293    
294     (defsetf sigcontext-floating-point-modes %set-sigcontext-floating-point-modes)
295    
296 ram 1.1
297     ;;; EXTERN-ALIEN-NAME -- interface.
298     ;;;
299     ;;; The loader uses this to convert alien names to the form they occure in
300     ;;; the symbol table (for example, prepending an underscore).
301     ;;;
302     (defun extern-alien-name (name)
303     (declare (type simple-string name))
304 cshapiro 1.25 name)
305 ram 1.1
306 moore 1.21 #+(and (or linux (and freebsd elf)) (not linkage-table))
307     (defun lisp::foreign-symbol-address-aux (name flavor)
308     (declare (ignore flavor))
309 dtc 1.8 (multiple-value-bind (value found)
310     (gethash name lisp::*foreign-symbols* 0)
311     (if found
312     value
313     (multiple-value-bind (value found)
314     (gethash
315 pmai 1.20 (concatenate 'string "PVE_stub_" name)
316 dtc 1.8 lisp::*foreign-symbols* 0)
317     (if found
318     value
319     (let ((value (system:alternate-get-global-address name)))
320     (when (zerop value)
321 rtoy 1.32.2.3 (error _"Unknown foreign symbol: ~S" name))
322 dtc 1.8 value))))))
323 ram 1.1
324 moore 1.21
325 ram 1.1
326     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
327     ;;;
328 dtc 1.14 ;;; Do whatever is necessary to make the given code component
329     ;;; executable - nothing on the x86.
330 ram 1.1 ;;;
331     (defun sanctify-for-execution (component)
332     (declare (ignore component))
333     nil)
334    
335     ;;; FLOAT-WAIT
336     ;;;
337     ;;; This is used in error.lisp to insure floating-point exceptions
338     ;;; are properly trapped. The compiler translates this to a VOP.
339 dtc 1.14 ;;;
340 ram 1.1 (defun float-wait()
341     (float-wait))
342    
343     ;;; FLOAT CONSTANTS
344     ;;;
345 dtc 1.14 ;;; These are used by the FP move-from-{single|double} VOPs rather
346     ;;; than the i387 load constant instructions to avoid consing in some
347     ;;; cases. Note these are initialise by genesis as they are needed
348     ;;; early.
349     ;;;
350     (defvar *fp-constant-0s0*)
351     (defvar *fp-constant-1s0*)
352     (defvar *fp-constant-0d0*)
353     (defvar *fp-constant-1d0*)
354     ;;; The long-float constants.
355     (defvar *fp-constant-0l0*)
356     (defvar *fp-constant-1l0*)
357     (defvar *fp-constant-pi*)
358     (defvar *fp-constant-l2t*)
359     (defvar *fp-constant-l2e*)
360     (defvar *fp-constant-lg2*)
361     (defvar *fp-constant-ln2*)
362 dtc 1.3
363 dtc 1.7 ;;; Enable/Disable scavenging of the read-only space.
364 dtc 1.12 (defvar *scavenge-read-only-space* nil)
365 dtc 1.7
366 dtc 1.3 ;;; The current alien stack pointer; saved/restored for non-local
367     ;;; exits.
368     (defvar *alien-stack*)
369 dtc 1.4
370 dtc 1.12 ;;; Support for the MT19937 random number generator. The update
371     ;;; function is implemented as an assembly routine. This definition is
372     ;;; transformed to a call to this routine allowing its use in byte
373     ;;; compiled code.
374     ;;;
375     (defun random-mt19937 (state)
376     (declare (type (simple-array (unsigned-byte 32) (627)) state))
377     (random-mt19937 state))
378 dtc 1.15
379    
380     ;;;; Useful definitions for writing thread safe code.
381    
382     (in-package "KERNEL")
383    
384     (export '(atomic-push-symbol-value atomic-pop-symbol-value
385     atomic-pusha atomic-pushd atomic-push-vector))
386    
387     (defun %instance-set-conditional (object slot test-value new-value)
388     (declare (type instance object)
389     (type index slot))
390 rtoy 1.32.2.2 _N"Atomically compare object's slot value to test-value and if EQ store
391 dtc 1.15 new-value in the slot. The original value of the slot is returned."
392     (%instance-set-conditional object slot test-value new-value))
393    
394     (defun set-symbol-value-conditional (symbol test-value new-value)
395     (declare (type symbol symbol))
396 rtoy 1.32.2.2 _N"Atomically compare symbol's value to test-value and if EQ store
397 dtc 1.15 new-value in symbol's value slot and return the original value."
398     (set-symbol-value-conditional symbol test-value new-value))
399    
400     (defun rplaca-conditional (cons test-value new-value)
401     (declare (type cons cons))
402 rtoy 1.32.2.2 _N"Atomically compare the car of CONS to test-value and if EQ store
403 dtc 1.15 new-value its car and return the original value."
404     (rplaca-conditional cons test-value new-value))
405    
406     (defun rplacd-conditional (cons test-value new-value)
407     (declare (type cons cons))
408 rtoy 1.32.2.2 _N"Atomically compare the cdr of CONS to test-value and if EQ store
409 dtc 1.15 new-value its cdr and return the original value."
410     (rplacd-conditional cons test-value new-value))
411    
412     (defun data-vector-set-conditional (vector index test-value new-value)
413     (declare (type simple-vector vector))
414 rtoy 1.32.2.2 _N"Atomically compare an element of vector to test-value and if EQ store
415 dtc 1.15 new-value the element and return the original value."
416     (data-vector-set-conditional vector index test-value new-value))
417    
418     (defmacro atomic-push-symbol-value (val symbol)
419 rtoy 1.32.2.2 _N"Thread safe push of val onto the list in the symbol global value."
420 dtc 1.15 (ext:once-only ((n-val val))
421     (let ((new-list (gensym))
422     (old-list (gensym)))
423     `(let ((,new-list (cons ,n-val nil)))
424     (loop
425     (let ((,old-list ,symbol))
426     (setf (cdr ,new-list) ,old-list)
427     (when (eq (set-symbol-value-conditional
428     ',symbol ,old-list ,new-list)
429     ,old-list)
430     (return ,new-list))))))))
431    
432     (defmacro atomic-pop-symbol-value (symbol)
433 rtoy 1.32.2.2 _N"Thread safe pop from the list in the symbol global value."
434 dtc 1.15 (let ((new-list (gensym))
435     (old-list (gensym)))
436     `(loop
437     (let* ((,old-list ,symbol)
438     (,new-list (cdr ,old-list)))
439     (when (eq (set-symbol-value-conditional
440     ',symbol ,old-list ,new-list)
441     ,old-list)
442     (return (car ,old-list)))))))
443    
444     (defmacro atomic-pusha (val cons)
445 rtoy 1.32.2.2 _N"Thread safe push of val onto the list in the car of cons."
446 dtc 1.15 (once-only ((n-val val)
447     (n-cons cons))
448     (let ((new-list (gensym))
449     (old-list (gensym)))
450     `(let ((,new-list (cons ,n-val nil)))
451     (loop
452     (let ((,old-list (car ,n-cons)))
453     (setf (cdr ,new-list) ,old-list)
454     (when (eq (rplaca-conditional ,n-cons ,old-list ,new-list)
455     ,old-list)
456     (return ,new-list))))))))
457    
458     (defmacro atomic-pushd (val cons)
459 rtoy 1.32.2.2 _N"Thread safe push of val onto the list in the cdr of cons."
460 dtc 1.15 (once-only ((n-val val)
461     (n-cons cons))
462     (let ((new-list (gensym))
463     (old-list (gensym)))
464     `(let ((,new-list (cons ,n-val nil)))
465     (loop
466     (let ((,old-list (cdr ,n-cons)))
467     (setf (cdr ,new-list) ,old-list)
468     (when (eq (rplacd-conditional ,n-cons ,old-list ,new-list)
469     ,old-list)
470     (return ,new-list))))))))
471    
472     (defmacro atomic-push-vector (val vect index)
473 rtoy 1.32.2.2 _N"Thread safe push of val onto the list in the vector element."
474 dtc 1.15 (once-only ((n-val val)
475     (n-vect vect)
476     (n-index index))
477     (let ((new-list (gensym))
478     (old-list (gensym)))
479     `(let ((,new-list (cons ,n-val nil)))
480     (loop
481     (let ((,old-list (svref ,n-vect ,n-index)))
482     (setf (cdr ,new-list) ,old-list)
483     (when (eq (data-vector-set-conditional
484     ,n-vect ,n-index ,old-list ,new-list)
485     ,old-list)
486     (return ,new-list))))))))
487 moore 1.21
488     #+linkage-table
489     (progn
490     (defun lisp::foreign-symbol-address-aux (name flavor)
491     (let ((entry-num (lisp::register-foreign-linkage name flavor)))
492     (+ #.vm:target-foreign-linkage-space-start
493     (* entry-num vm:target-foreign-linkage-entry-size))))
494    
495     (defun lisp::find-foreign-symbol (addr)
496     (declare (type (unsigned-byte 32) addr))
497     (when (>= addr vm:target-foreign-linkage-space-start)
498     (let ((entry (/ (- addr vm:target-foreign-linkage-space-start)
499     vm:target-foreign-linkage-entry-size)))
500     (when (< entry (lisp::foreign-linkage-symbols))
501     (lisp::foreign-linkage-entry entry)))))
502     )

  ViewVC Help
Powered by ViewVC 1.1.5