CMUCL commit: amd64-dd-branch src (3 files)
Raymond Toy
rtoy at common-lisp.net
Wed Nov 4 04:45:23 CET 2009
Date: Tuesday, November 3, 2009 @ 22:45:23
Author: rtoy
Path: /project/cmucl/cvsroot/src
Tag: amd64-dd-branch
Modified: code/amd64-vm.lisp code/float-trap.lisp lisp/Linux-os.c
Make amd64 look more like current x86.
code/amd64-vm.lisp:
o Remove all of the sigcontext structure definitions and make it be
just an sap.
o Instead of direct access to sigcontext structures, call out to C, as
is done on x86.
code/float-trap.lisp:
o Update floating-point-modes stuff to work for x86 and amd64.
lisp/Linux-os.c:
o Add missing os_sigcontext_fpu_reg and os_sigcontext_fpu_modes for
amd64, just like on x86.
----------------------+
code/amd64-vm.lisp | 258 +++++++++----------------------------------------
code/float-trap.lisp | 6 -
lisp/Linux-os.c | 53 +++++++++-
3 files changed, 103 insertions(+), 214 deletions(-)
Index: src/code/amd64-vm.lisp
diff -u src/code/amd64-vm.lisp:1.4 src/code/amd64-vm.lisp:1.4.2.1
--- src/code/amd64-vm.lisp:1.4 Fri Oct 9 23:00:03 2009
+++ src/code/amd64-vm.lisp Tue Nov 3 22:45:23 2009
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/amd64-vm.lisp,v 1.4 2009-10-10 03:00:03 agoncharov Exp $")
+ "$Header: /project/cmucl/cvsroot/src/code/amd64-vm.lisp,v 1.4.2.1 2009-11-04 03:45:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -31,141 +31,12 @@
;;;; The sigcontext structure.
-;;;; Add machine specific features to *features*
-(pushnew :amd64 *features*)
+(def-alien-type sigcontext system-area-pointer)
-
+;;;; Add machine specific features to *features*
-#+linux
-(def-alien-type nil
- (struct fpreg
- (significand (array unsigned-short 4))
- (exponent unsigned-short)))
-#+linux
-(def-alien-type nil
- (struct fpstate
- (cw unsigned-long)
- (sw unsigned-long)
- (tag unsigned-long)
- (ipoff unsigned-long)
- (cssel unsigned-long)
- (dataoff unsigned-long)
- (datasel unsigned-long)
- (fpreg (array (struct fpreg) 8))
- (status unsigned-long)))
-
-#+freebsd
-(def-alien-type sigcontext
- (struct nil
- (sc-mask (array unsigned-int 4))
- (sc-onstack unsigned-int)
- (sc-gs unsigned-int)
- (sc-fs unsigned-int)
- (sc-es unsigned-int)
- (sc-ds unsigned-int)
- (sc-edi unsigned-int)
- (sc-esi unsigned-int)
- (sc-fp unsigned-int)
- (sc-isp unsigned-int)
- (sc-ebx unsigned-int)
- (sc-edx unsigned-int)
- (sc-ecx unsigned-int)
- (sc-eax unsigned-int)
- (trapno unsigned-int)
- (err unsigned-int)
- (sc-pc unsigned-int)
- (sc-cs unsigned-int)
- (sc-efl unsigned-int) ; sc_ps
- (sc-sp unsigned-int)
- (sc-ss unsigned-int)))
-
-;;; OpenBSD/NetBSD also have sigcontext structs that look more like Linux.
-#+openbsd
-(def-alien-type sigcontext
- (struct nil
- (sc-gs unsigned-int)
- (sc-fs unsigned-int)
- (sc-es unsigned-int)
- (sc-ds unsigned-int)
- (sc-edi unsigned-int)
- (sc-esi unsigned-int)
- (sc-fp unsigned-int) ;; ebp
- (sc-ebx unsigned-int)
- (sc-edx unsigned-int)
- (sc-ecx unsigned-int)
- (sc-eax unsigned-int)
- (sc-pc unsigned-int)
- (sc-cs unsigned-int)
- (sc-efl unsigned-int) ; sc_ps
- (sc-sp unsigned-int)
- (sc-ss unsigned-int)
- (sc-onstack unsigned-int)
- (sc-mask unsigned-int)
- (sc-trapno unsigned-int)
- (sc-err unsigned-int)
- ))
-
-#+netbsd
-(def-alien-type sigcontext
- (struct nil
- (sc-gs unsigned-int)
- (sc-fs unsigned-int)
- (sc-es unsigned-int)
- (sc-ds unsigned-int)
- (sc-edi unsigned-int)
- (sc-esi unsigned-int)
- (sc-fp unsigned-int) ;; ebp
- (sc-ebx unsigned-int)
- (sc-edx unsigned-int)
- (sc-ecx unsigned-int)
- (sc-eax unsigned-int)
- (sc-pc unsigned-int)
- (sc-cs unsigned-int)
- (sc-efl unsigned-int) ; sc_ps
- (sc-sp unsigned-int)
- (sc-ss unsigned-int)
- (sc-onstack unsigned-int)
- ;; Old NetBSD 1.3 signal mask
- (sc-oldmask unsigned-int)
- (sc-trapno unsigned-int)
- (sc-err unsigned-int)
- ;; New signal mask (post NetBSD 1.3)
- (sc-mask (array unsigned-int 4))
- ))
-
-;; For Linux...
-#+linux
-(def-alien-type sigcontext
- (struct nil
- (sc-r8 unsigned-long)
- (sc-r9 unsigned-long)
- (sc-r10 unsigned-long)
- (sc-r11 unsigned-long)
- (sc-r12 unsigned-long)
- (sc-r13 unsigned-long)
- (sc-r14 unsigned-long)
- (sc-r15 unsigned-long)
- (sc-rdi unsigned-long)
- (sc-rsi unsigned-long)
- (rbp unsigned-long)
- (sc-rbx unsigned-long)
- (sc-rdx unsigned-long)
- (sc-rax unsigned-long)
- (sc-rcx unsigned-long)
- (sc-sp unsigned-long)
- (sc-pc unsigned-long)
- (sc-efl unsigned-long)
- (sc-cs unsigned-short)
- (gs unsigned-short)
- (fs unsigned-short)
- (__pad0 unsigned-short)
- (err unsigned-long)
- (trapno unsigned-long)
- (sc-mask unsigned-long)
- (cr2 unsigned-long)
- (fpstate (* (struct fpstate)))
- (__reserved1 (array unsigned-long 8))))
+(pushnew :amd64 *features*)
;;;; MACHINE-TYPE and MACHINE-VERSION
@@ -306,7 +177,7 @@
(defun internal-error-arguments (scp)
(declare (type (alien (* sigcontext)) scp))
(with-alien ((scp (* sigcontext) scp))
- (let ((pc (int-sap (slot scp 'sc-pc))))
+ (let ((pc (sigcontext-program-counter scp)))
(declare (type system-area-pointer pc))
;; using INT3 the pc is .. INT3 <here> code length bytes...
(let* ((length (sap-ref-8 pc 1))
@@ -333,42 +204,31 @@
;;;
(defun sigcontext-program-counter (scp)
(declare (type (alien (* sigcontext)) scp))
- (with-alien ((scp (* sigcontext) scp))
- (int-sap (slot scp 'sc-pc))))
+ (let ((fn (extern-alien "os_sigcontext_pc"
+ (function system-area-pointer
+ (* sigcontext)))))
+ (sap-ref-sap (alien-funcall fn scp) 0)))
;;; SIGCONTEXT-REGISTER -- Interface.
;;;
;;; An escape register saves the value of a register for a frame that someone
;;; interrupts.
;;;
-
(defun sigcontext-register (scp index)
(declare (type (alien (* sigcontext)) scp))
- (with-alien ((scp (* sigcontext) scp))
- (case index ; ugly -- I know.
- (#.eax-offset (slot scp 'sc-eax))
- (#.ecx-offset (slot scp 'sc-ecx))
- (#.edx-offset (slot scp 'sc-edx))
- (#.ebx-offset (slot scp 'sc-ebx))
- (#.esp-offset (slot scp 'sc-sp))
- (#.ebp-offset (slot scp #-linux 'sc-fp #+linux 'ebp))
- (#.esi-offset (slot scp 'sc-esi))
- (#.edi-offset (slot scp 'sc-edi)))))
-
+ (let ((fn (extern-alien "os_sigcontext_reg"
+ (function system-area-pointer
+ (* sigcontext)
+ (integer 32)))))
+ (sap-ref-32 (alien-funcall fn scp index) 0)))
(defun %set-sigcontext-register (scp index new)
(declare (type (alien (* sigcontext)) scp))
- (with-alien ((scp (* sigcontext) scp))
- (case index
- (#.eax-offset (setf (slot scp 'sc-eax) new))
- (#.ecx-offset (setf (slot scp 'sc-ecx) new))
- (#.edx-offset (setf (slot scp 'sc-edx) new))
- (#.ebx-offset (setf (slot scp 'sc-ebx) new))
- (#.esp-offset (setf (slot scp 'sc-sp) new))
- (#.ebp-offset (setf (slot scp #-linux 'sc-fp #+linux 'ebp) new))
- (#.esi-offset (setf (slot scp 'sc-esi) new))
- (#.edi-offset (setf (slot scp 'sc-edi) new))))
- new)
+ (let ((fn (extern-alien "os_sigcontext_reg"
+ (function system-area-pointer
+ (* sigcontext)
+ (integer 32)))))
+ (setf (sap-ref-32 (alien-funcall fn scp index) 0) new)))
(defsetf sigcontext-register %set-sigcontext-register)
@@ -378,40 +238,23 @@
;;; Like SIGCONTEXT-REGISTER, but returns the value of a float register.
;;; Format is the type of float to return.
;;;
-#+linux
(defun sigcontext-float-register (scp index format)
(declare (type (alien (* sigcontext)) scp))
- (with-alien ((scp (* sigcontext) scp))
- (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
- 'fpreg)
- index))))
- (coerce (sys:sap-ref-long reg-sap 0) format))))
-
-;;; Not supported on Free/OpenBSD because the floating point state is not
-;;; saved. For now we assume this is true for all modern BSDs
-#+BSD
-(defun sigcontext-float-register (scp index format)
- (declare (ignore scp index))
- (coerce 0l0 format))
-
-#+linux
-(defun %set-sigcontext-float-register (scp index format new-value)
+ (let ((fn (extern-alien "os_sigcontext_fpu_reg"
+ (function system-area-pointer
+ (* sigcontext)
+ (integer 32)))))
+ (coerce (sap-ref-long (alien-funcall fn scp index) 0) format)))
+;;;
+(defun %set-sigcontext-float-register (scp index format new)
(declare (type (alien (* sigcontext)) scp))
- (with-alien ((scp (* sigcontext) scp))
- (let ((reg-sap (alien-sap (deref (slot (deref (slot scp 'fpstate) 0)
- 'fpreg)
- index))))
- (declare (ignorable reg-sap))
- #+not-yet
- (setf (sys:sap-ref-long reg-sap 0) (coerce new-value 'long-float))
- (coerce new-value format))))
-
-;;; Not supported on Free/OpenBSD.
-#+BSD
-(defun %set-sigcontext-float-register (scp index format new-value)
- (declare (ignore scp index))
- (coerce new-value format))
-
+ (let ((fn (extern-alien "os_sigcontext_fpu_reg"
+ (function system-area-pointer
+ (* sigcontext)
+ (integer 32)))))
+ (let* ((sap (alien-funcall fn scp index))
+ (result (setf (sap-ref-long sap 0) (coerce new 'long-float))))
+ (coerce result format))))
;;;
(defsetf sigcontext-float-register %set-sigcontext-float-register)
@@ -420,25 +263,23 @@
;;; Given a sigcontext pointer, return the floating point modes word in the
;;; same format as returned by FLOATING-POINT-MODES.
;;;
-
-#+BSD
-(defun sigcontext-floating-point-modes (scp)
- (declare (type (alien (* sigcontext)) scp)
- (ignore scp))
- ;; This is broken until some future release of FreeBSD/OpenBSD!!!
- (floating-point-modes))
-
-#+linux
(defun sigcontext-floating-point-modes (scp)
(declare (type (alien (* sigcontext)) scp))
- (let ((cw (slot (deref (slot scp 'fpstate) 0) 'cw))
- (sw (slot (deref (slot scp 'fpstate) 0) 'sw)))
- ;;(format t "cw = ~4x~%sw = ~4x~%" cw sw)
- ;; NOT TESTED -- clear sticky bits to clear interrupt condition
- (setf (slot (deref (slot scp 'fpstate) 0) 'sw) (logandc2 sw #x3f))
- ;;(format t "new sw = ~x~%" (slot (deref (slot scp 'fpstate) 0) 'sw))
- ;; simulate floating-point-modes VOP
- (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f))))
+ (let ((fn (extern-alien "os_sigcontext_fpu_modes"
+ (function (integer 32)
+ (* sigcontext)))))
+ (alien-funcall fn scp)))
+
+(defun %set-sigcontext-floating-point-modes (scp new-mode)
+ (declare (type (alien (* sigcontext)) scp))
+ (let ((fn (extern-alien "os_set_sigcontext_fpu_modes"
+ (function (integer 32)
+ (* sigcontext)
+ c-call:unsigned-int))))
+ (alien-funcall fn scp new-mode)
+ new-mode))
+
+(defsetf sigcontext-floating-point-modes %set-sigcontext-floating-point-modes)
;;; EXTERN-ALIEN-NAME -- interface.
@@ -448,9 +289,6 @@
;;;
(defun extern-alien-name (name)
(declare (type simple-string name))
- #+(and bsd (not elf))
- (concatenate 'string "_" name)
- #-(and bsd (not elf))
name)
#+(and (or linux (and freebsd elf)) (not linkage-table))
Index: src/code/float-trap.lisp
diff -u src/code/float-trap.lisp:1.35 src/code/float-trap.lisp:1.35.8.1
--- src/code/float-trap.lisp:1.35 Mon Jul 6 09:29:57 2009
+++ src/code/float-trap.lisp Tue Nov 3 22:45:23 2009
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/code/float-trap.lisp,v 1.35 2009-07-06 13:29:57 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/code/float-trap.lisp,v 1.35.8.1 2009-11-04 03:45:23 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -54,13 +54,13 @@
;;; Interpreter stubs.
;;;
-#+(not x86)
+#+(not (or x86 amd64))
(progn
(defun floating-point-modes () (floating-point-modes))
(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
)
-#+(and x86 (not sse2))
+#+(and (or x86 amd64) (not sse2))
(progn
(defun floating-point-modes ()
(let ((x87-modes (vm::x87-floating-point-modes)))
Index: src/lisp/Linux-os.c
diff -u src/lisp/Linux-os.c:1.44.2.1 src/lisp/Linux-os.c:1.44.2.2
--- src/lisp/Linux-os.c:1.44.2.1 Mon Nov 2 09:29:46 2009
+++ src/lisp/Linux-os.c Tue Nov 3 22:45:23 2009
@@ -15,7 +15,7 @@
* GENCGC support by Douglas Crosher, 1996, 1997.
* Alpha support by Julian Dolby, 1999.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.44.2.1 2009-11-02 14:29:46 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.44.2.2 2009-11-04 03:45:23 rtoy Exp $
*
*/
@@ -199,6 +199,57 @@
return (unsigned long *) &scp->uc_mcontext.gregs[REG_RIP];
}
+unsigned char *
+os_sigcontext_fpu_reg(ucontext_t *scp, int offset)
+{
+ fpregset_t fpregs = scp->uc_mcontext.fpregs;
+
+ if (fpregs == NULL) {
+ return NULL;
+ } else {
+ return (unsigned char *) &fpregs->_st[offset];
+ }
+}
+
+unsigned int
+os_sigcontext_fpu_modes(ucontext_t *scp)
+{
+ unsigned int modes;
+ unsigned short cw, sw;
+
+ if (scp->uc_mcontext.fpregs == NULL) {
+ cw = 0;
+ sw = 0x3f;
+ } else {
+ cw = scp->uc_mcontext.fpregs->cwd & 0xffff;
+ sw = scp->uc_mcontext.fpregs->swd & 0xffff;
+ }
+
+ modes = ((cw & 0x3f) << 7) | (sw & 0x3f);
+
+#ifdef FEATURE_SSE2
+ /*
+ * Add in the SSE2 part, if we're running the sse2 core.
+ */
+ if (fpu_mode == SSE2) {
+ struct _fpstate *fpstate;
+ unsigned long mxcsr;
+
+ fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs;
+ if (fpstate->magic == 0xffff) {
+ mxcsr = 0;
+ } else {
+ mxcsr = fpstate->mxcsr;
+ DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr));
+ }
+
+ modes |= mxcsr;
+ }
+#endif
+
+ modes ^= (0x3f << 7);
+ return modes;
+}
#endif
os_vm_address_t
More information about the cmucl-commit
mailing list