/[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.8.2.2.1 - (hide annotations)
Sun Oct 12 04:09:48 2008 UTC (5 years, 6 months ago) by rtoy
Branch: sse2-packed-branch
CVS Tags: sse2-packed-2008-11-12, sse2-merge-with-2008-11
Changes since 1.29.8.2: +3 -1 lines
Add complex floating-point vops to speed up complex arithmetic.

bootfiles/19e/boot-2008-09-sse2.lisp:
o Add :complex-fp-vops feature

code/sparc-svr4-vm.lisp:
code/x86-vm.lisp:
o Register :complex-fp-vops feature

compiler/float-tran.lisp:
o Clean up deftransforms for complex arithmetic to support
  complex-fp-vops.
o Add special vop for complex division that takes advantage of the
  fast complex multiply.

compiler/x86/float-sse2.lisp:
o Add vops for complex arithmetic.
o Add guard for sse3 for some vops that need sse3 instructions.

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

  ViewVC Help
Powered by ViewVC 1.1.5