/[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 - (hide annotations)
Sat Jan 23 15:24:16 2010 UTC (4 years, 2 months ago) by rtoy
Branch: MAIN
CVS Tags: intl-2-branch-base, pre-merge-intl-branch, snapshot-2010-03, snapshot-2010-02, intl-branch-base
Branch point for: intl-branch, intl-2-branch
Changes since 1.31: +2 -2 lines
:SSE2 should not be a runtime feature saved in internals.h.  This is
handled by the makefile which sets -DFEATURE_SSE2 appropriately
because :SSE2 is a lisp feature saved in internals.inc.

This was causing the C code to be rebuilt when building x87 and then
sse2 in the same tree.  It's not necessary to do that and should not
be done.
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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/x86-vm.lisp,v 1.32 2010/01/23 15:24:16 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     (export '(fixup-code-object internal-error-arguments
28     sigcontext-program-counter sigcontext-register
29     sigcontext-float-register sigcontext-floating-point-modes
30 dtc 1.9 extern-alien-name sanctify-for-execution))
31 ram 1.1
32 rtoy 1.30 #+complex-fp-vops
33     (sys:register-lisp-feature :complex-fp-vops)
34    
35     #+(or x87 (not :sse2))
36     (sys:register-lisp-feature :x87)
37 agoncharov 1.31 #+sse2
38     (progn
39     (setf *features* (delete :x87 *features*))
40 rtoy 1.32 (sys:register-lisp-feature :sse2))
41 rtoy 1.30
42 ram 1.1
43     ;;;; The sigcontext structure.
44 cshapiro 1.29
45     (def-alien-type sigcontext system-area-pointer)
46    
47 ram 1.1 ;;;; 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 dtc 1.12 ;;; Fixup-Code-Object -- Interface
68     ;;;
69 ram 1.1 ;;; This gets called by LOAD to resolve newly positioned objects
70     ;;; with things (like code instructions) that have to refer to them.
71 dtc 1.12 ;;;
72 dtc 1.7 ;;; 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 moore 1.21 ;;; XXX
78 ram 1.1 (defun fixup-code-object (code offset fixup kind)
79     (declare (type index offset))
80 dtc 1.12 (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 ram 1.1
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 cshapiro 1.27 (let ((pc (sigcontext-program-counter scp)))
191 ram 1.1 (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 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_pc"
218     (function system-area-pointer
219     (* sigcontext)))))
220     (sap-ref-sap (alien-funcall fn scp) 0)))
221 rtoy 1.22
222 ram 1.1 ;;; 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 cshapiro 1.29 (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 ram 1.1
235     (defun %set-sigcontext-register (scp index new)
236     (declare (type (alien (* sigcontext)) scp))
237 cshapiro 1.29 (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 rtoy 1.22
243 ram 1.1 (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 dtc 1.13 ;;;
251 ram 1.1 (defun sigcontext-float-register (scp index format)
252     (declare (type (alien (* sigcontext)) scp))
253 cshapiro 1.29 (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 ram 1.1 (declare (type (alien (* sigcontext)) scp))
261 cshapiro 1.29 (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 ram 1.1 ;;;
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 cshapiro 1.29 (let ((fn (extern-alien "os_sigcontext_fpu_modes"
279     (function (integer 32)
280     (* sigcontext)))))
281     (alien-funcall fn scp)))
282 ram 1.1
283 rtoy 1.30 (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 ram 1.1
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 cshapiro 1.25 name)
303 ram 1.1
304 moore 1.21 #+(and (or linux (and freebsd elf)) (not linkage-table))
305     (defun lisp::foreign-symbol-address-aux (name flavor)
306     (declare (ignore flavor))
307 dtc 1.8 (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 pmai 1.20 (concatenate 'string "PVE_stub_" name)
314 dtc 1.8 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 ram 1.1
322 moore 1.21
323 ram 1.1
324     ;;; SANCTIFY-FOR-EXECUTION -- Interface.
325     ;;;
326 dtc 1.14 ;;; Do whatever is necessary to make the given code component
327     ;;; executable - nothing on the x86.
328 ram 1.1 ;;;
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 dtc 1.14 ;;;
338 ram 1.1 (defun float-wait()
339     (float-wait))
340    
341     ;;; FLOAT CONSTANTS
342     ;;;
343 dtc 1.14 ;;; 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 dtc 1.3
361 dtc 1.7 ;;; Enable/Disable scavenging of the read-only space.
362 dtc 1.12 (defvar *scavenge-read-only-space* nil)
363 dtc 1.7
364 dtc 1.3 ;;; The current alien stack pointer; saved/restored for non-local
365     ;;; exits.
366     (defvar *alien-stack*)
367 dtc 1.4
368 dtc 1.12 ;;; 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 dtc 1.15
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 moore 1.21
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