/[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 - (show 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 ;;; -*- 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.8.2.2.1 2008/10/12 04:09:48 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 #+sse2
33 (sys:register-lisp-runtime-feature :sse2)
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
40
41 ;;;; The sigcontext structure.
42
43 (def-alien-type sigcontext system-area-pointer)
44
45 ;;;; 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 ;;; Fixup-Code-Object -- Interface
66 ;;;
67 ;;; This gets called by LOAD to resolve newly positioned objects
68 ;;; with things (like code instructions) that have to refer to them.
69 ;;;
70 ;;; 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 ;;; XXX
76 (defun fixup-code-object (code offset fixup kind)
77 (declare (type index offset))
78 (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
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 (let ((pc (sigcontext-program-counter scp)))
189 (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 (let ((fn (extern-alien "os_sigcontext_pc"
216 (function system-area-pointer
217 (* sigcontext)))))
218 (sap-ref-sap (alien-funcall fn scp) 0)))
219
220 ;;; 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 (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
233 (defun %set-sigcontext-register (scp index new)
234 (declare (type (alien (* sigcontext)) scp))
235 (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
241 (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 ;;;
249 (defun sigcontext-float-register (scp index format)
250 (declare (type (alien (* sigcontext)) scp))
251 (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 (declare (type (alien (* sigcontext)) scp))
259 (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 ;;;
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 (let ((fn (extern-alien "os_sigcontext_fpu_modes"
277 (function (integer 32)
278 (* sigcontext)))))
279 (alien-funcall fn scp)))
280
281 (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
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 name)
301
302 #+(and (or linux (and freebsd elf)) (not linkage-table))
303 (defun lisp::foreign-symbol-address-aux (name flavor)
304 (declare (ignore flavor))
305 (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 (concatenate 'string "PVE_stub_" name)
312 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
320
321
322 ;;; SANCTIFY-FOR-EXECUTION -- Interface.
323 ;;;
324 ;;; Do whatever is necessary to make the given code component
325 ;;; executable - nothing on the x86.
326 ;;;
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 ;;;
336 (defun float-wait()
337 (float-wait))
338
339 ;;; FLOAT CONSTANTS
340 ;;;
341 ;;; 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
359 ;;; Enable/Disable scavenging of the read-only space.
360 (defvar *scavenge-read-only-space* nil)
361
362 ;;; The current alien stack pointer; saved/restored for non-local
363 ;;; exits.
364 (defvar *alien-stack*)
365
366 ;;; 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
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
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