From ffde26c7766d109683ab73622b5b4294a3dd1c52 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Mon, 30 May 2005 05:25:44 +0000 Subject: [PATCH] 0.9.1.8: * Fix typo (current-dynamic-space-spart -> current-dynamic-space-start) in the gencgc branch of the "clean up DYNAMIC-SPACE-START and -END ugliness on cheney-platforms" changes in 0.9.1.5. * Fix compiling with GCC 4 on x86 and x86-64 (sbcl-devel "Fixes for gcc4", Sascha Wilde). * Remove a leftover "with-tn@fp-top(x)" from x86-64/float.lisp (sbcl-devel , James Knight) * More x86-64 fp cleanups. (sbcl-devel "x86-64 fp exceptions", "x86-64 move-*-float-arg bug", James Knight 2005-05-27/29). --- NEWS | 4 +++ src/code/float-trap.lisp | 2 +- src/code/gc.lisp | 2 +- src/code/x86-64-vm.lisp | 8 ++++++ src/compiler/x86-64/float.lisp | 62 ++-------------------------------------- src/compiler/x86-64/parms.lisp | 24 ++++------------ src/compiler/x86-64/sap.lisp | 26 ----------------- src/runtime/x86-64-arch.c | 60 ++++++++++++++++++++++++++++++++++++-- src/runtime/x86-64-linux-os.c | 13 +++++++-- src/runtime/x86-arch.c | 6 ++-- version.lisp-expr | 2 +- 11 files changed, 94 insertions(+), 115 deletions(-) diff --git a/NEWS b/NEWS index d553f1e..fc3e347 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,10 @@ changes in sbcl-0.9.2 relative to sbcl-0.9.1: * SB-MOP:ENSURE-CLASS-USING-CLASS now accepts a class as the :METACLASS argument in addition to a class name. (reported by Bruno Haible for CMUCL, patch for CMUCL by Gerd Moellman) + * bug fix: sbcl runtime can now be compiled with gcc4 (thanks to + Sascha Wilde) + * bug fix: more cleanups to the floating point exception handling on + x86-64 (thanks to James Knight) * fixed some bugs revealed by Paul Dietz' test suite: ** Invalid dotted lists no longer raise a read error when *READ-SUPPRESS* is T diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index fd3991a..ab89ba2 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -48,7 +48,7 @@ ;;; interpreter stubs for floating point modes get/setters for the ;;; alpha have been removed to alpha-vm.lisp, as they are implemented ;;; in C rather than as VOPs. -#!-alpha +#!-(or alpha x86-64) (progn (defun floating-point-modes () (floating-point-modes)) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 6daa745..af6a759 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -24,7 +24,7 @@ #!-sb-fluid (declaim (inline current-dynamic-space-start)) #!+gencgc -(defun current-dynamic-space-spart () sb!vm:dynamic-space-start) +(defun current-dynamic-space-start () sb!vm:dynamic-space-start) #!-gencgc (def-c-var-fun current-dynamic-space-start "current_dynamic_space") diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp index a9698db..286c292 100644 --- a/src/code/x86-64-vm.lisp +++ b/src/code/x86-64-vm.lisp @@ -271,6 +271,14 @@ (sb!alien:unsigned 32) (context (* os-context-t))) +(define-alien-routine + ("arch_get_fp_modes" floating-point-modes) (sb!alien:unsigned 32)) + +(define-alien-routine + ("arch_set_fp_modes" %floating-point-modes-setter) void (fp (sb!alien:unsigned 32))) + +(defun (setf floating-point-modes) (val) (%floating-point-modes-setter val)) + ;;;; INTERNAL-ERROR-ARGS diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index 8c00995..c885e13 100644 --- a/src/compiler/x86-64/float.lisp +++ b/src/compiler/x86-64/float.lisp @@ -329,10 +329,9 @@ (:single 1) (:double 2) )) n-word-bytes))))) - (with-tn@fp-top(x) - ,@(ecase format - (:single '((inst movss ea x))) - (:double '((inst movsd ea x))))))))))) + ,@(ecase format + (:single '((inst movss ea x))) + (:double '((inst movsd ea x)))))))))) (define-move-vop ,name :move-arg (,sc descriptor-reg) (,sc))))) (frob move-single-float-arg single-reg single-stack :single) @@ -766,61 +765,6 @@ (inst shr lo-bits 32))) -;;;; float mode hackery - -(sb!xc:deftype float-modes () '(unsigned-byte 64)) ; really only 16 -(defknown floating-point-modes () float-modes (flushable)) -(defknown ((setf floating-point-modes)) (float-modes) - float-modes) - -(define-vop (floating-point-modes) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:translate floating-point-modes) - (:policy :fast-safe) - (:temporary (:sc unsigned-stack :from :argument :to :result) temp) - (:generator 8 - (inst stmxcsr temp) - (move res temp) - ;; Extract status from bytes 0-5 to bytes 16-21 - (inst and temp (1- (expt 2 6))) - (inst shl temp 16) - ;; Extract mask from bytes 7-12 to bytes 0-5 - (inst shr res 7) - (inst and res (1- (expt 2 6))) - ;; Flip the bits to convert from "1 means exception masked" to - ;; "1 means exception enabled". - (inst xor res (1- (expt 2 6))) - (inst or res temp))) - -(define-vop (set-floating-point-modes) - (:args (new :scs (unsigned-reg) :to :result :target res)) - (:results (res :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:result-types unsigned-num) - (:translate (setf floating-point-modes)) - (:policy :fast-safe) - (:temporary (:sc unsigned-reg :from :argument :to :result) temp1) - (:temporary (:sc unsigned-stack :from :argument :to :result) temp2) - (:generator 3 - (move res new) - (inst stmxcsr temp2) - ;; Clear status + masks - (inst and temp2 (lognot (logior (1- (expt 2 6)) - (ash (1- (expt 2 6)) 7)))) - ;; Replace current status - (move temp1 new) - (inst shr temp1 16) - (inst and temp1 (1- (expt 2 6))) - (inst or temp2 temp1) - ;; Replace exception masks - (move temp1 new) - (inst and temp1 (1- (expt 2 6))) - (inst xor temp1 (1- (expt 2 6))) - (inst shl temp1 7) - (inst or temp2 temp1) - (inst ldmxcsr temp2))) - ;;;; complex float VOPs diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp index ec06769..740c173 100644 --- a/src/compiler/x86-64/parms.lisp +++ b/src/compiler/x86-64/parms.lisp @@ -60,24 +60,13 @@ (def!constant double-float-hidden-bit (ash 1 20)) (def!constant double-float-trapping-nan-bit (ash 1 19)) -(def!constant long-float-bias 16382) -(defconstant-eqx long-float-exponent-byte (byte 15 0) #'equalp) -(defconstant-eqx long-float-significand-byte (byte 31 0) #'equalp) -(def!constant long-float-normal-exponent-min 1) -(def!constant long-float-normal-exponent-max #x7FFE) -(def!constant long-float-hidden-bit (ash 1 31)) ; actually not hidden -(def!constant long-float-trapping-nan-bit (ash 1 30)) - (def!constant single-float-digits (+ (byte-size single-float-significand-byte) 1)) (def!constant double-float-digits (+ (byte-size double-float-significand-byte) 32 1)) -(def!constant long-float-digits - (+ (byte-size long-float-significand-byte) 32 1)) - -;;; pfw -- from i486 microprocessor programmer's reference manual +;;; from AMD64 Architecture manual (def!constant float-invalid-trap-bit (ash 1 0)) (def!constant float-denormal-trap-bit (ash 1 1)) (def!constant float-divide-by-zero-trap-bit (ash 1 2)) @@ -90,12 +79,11 @@ (def!constant float-round-to-positive 2) (def!constant float-round-to-zero 3) -(defconstant-eqx float-rounding-mode (byte 2 10) #'equalp) -(defconstant-eqx float-sticky-bits (byte 6 16) #'equalp) -(defconstant-eqx float-traps-byte (byte 6 0) #'equalp) -(defconstant-eqx float-exceptions-byte (byte 6 16) #'equalp) -(defconstant-eqx float-precision-control (byte 2 8) #'equalp) -(def!constant float-fast-bit 0) ; no fast mode on x86 +(defconstant-eqx float-rounding-mode (byte 2 13) #'equalp) +(defconstant-eqx float-sticky-bits (byte 6 0) #'equalp) +(defconstant-eqx float-traps-byte (byte 6 7) #'equalp) +(defconstant-eqx float-exceptions-byte (byte 6 0) #'equalp) +(def!constant float-fast-bit 0) ; no fast mode on x86-64 ;;;; description of the target address space diff --git a/src/compiler/x86-64/sap.lisp b/src/compiler/x86-64/sap.lisp index 7cc36d3..49589af 100644 --- a/src/compiler/x86-64/sap.lisp +++ b/src/compiler/x86-64/sap.lisp @@ -377,32 +377,6 @@ (:generator 4 (inst movss (make-ea :dword :base sap :disp offset) value) (move result value))) - -;;;; SAP-REF-LONG -#+nil -(define-vop (sap-ref-long) - (:translate sap-ref-long) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) - (:results (result :scs (#!+long-float long-reg #!-long-float double-reg))) - (:result-types #!+long-float long-float #!-long-float double-float) - (:generator 5 - (with-empty-tn@fp-top(result) - (inst fldl (make-ea :qword :base sap :index offset))))) -#+nil -(define-vop (sap-ref-long-c) - (:translate sap-ref-long) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 64))) - (:info offset) - (:results (result :scs (#!+long-float long-reg #!-long-float double-reg))) - (:result-types #!+long-float long-float #!-long-float double-float) - (:generator 4 - (with-empty-tn@fp-top(result) - (inst fldl (make-ea :qword :base sap :disp offset))))) ;;; noise to convert normal lisp data objects into SAPs diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c index 64eeb06..1b1238b 100644 --- a/src/runtime/x86-64-arch.c +++ b/src/runtime/x86-64-arch.c @@ -84,7 +84,7 @@ void arch_skip_instruction(os_context_t *context) vlen = *(char*)(*os_context_pc_addr(context))++; /* Skip Lisp error arg data bytes. */ while (vlen-- > 0) { - ( (char*)(*os_context_pc_addr(context)) )++; + ++*os_context_pc_addr(context); } break; @@ -264,12 +264,12 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) break; case trap_Breakpoint: - (char*)(*os_context_pc_addr(context)) -= 1; + --*os_context_pc_addr(context); handle_breakpoint(signal, info, context); break; case trap_FunEndBreakpoint: - (char*)(*os_context_pc_addr(context)) -= 1; + --*os_context_pc_addr(context); *os_context_pc_addr(context) = (unsigned long)handle_fun_end_breakpoint(signal, info, context); break; @@ -391,3 +391,57 @@ arch_write_linkage_table_ref(void * reloc, void * data) } #endif + +/* These setup and check *both* the sse2 and x87 FPUs. While lisp code + only uses the sse2 FPU, other code (such as libc) may use the x87 FPU. + */ + +unsigned int +arch_get_fp_modes() +{ + unsigned int temp; + unsigned int result; + /* return the x87 exception flags ored in with the sse2 + * control+status flags */ + asm ("fnstsw %0" : "=m" (temp)); + result = temp; + result &= 0x3F; + asm ("stmxcsr %0" : "=m" (temp)); + result |= temp; + /* flip exception mask bits */ + return result ^ (0x3F << 7); +} + +struct fpenv +{ + unsigned short cw; + unsigned short unused1; + unsigned short sw; + unsigned short unused2; + unsigned int other_regs[5]; +}; + +void +arch_set_fp_modes(unsigned int mxcsr) +{ + struct fpenv f_env; + unsigned int temp; + + /* turn trap enable bits into exception mask */ + mxcsr ^= 0x3F << 7; + + /* set x87 modes */ + asm ("fnstenv %0" : "=m" (f_env)); + /* set control word: always long double precision + * get traps and rounding from mxcsr word */ + f_env.cw = 0x300 | ((mxcsr >> 7) & 0x3F) | (((mxcsr >> 13) & 0x3) << 10); + /* set status word: only override exception flags, from mxcsr */ + f_env.sw &= ~0x3F; + f_env.sw |= (mxcsr & 0x3F); + + asm ("fldenv %0" : : "m" (f_env)); + + /* now, simply, load up the mxcsr register */ + temp = mxcsr; + asm ("ldmxcsr %0" : : "m" (temp)); +} diff --git a/src/runtime/x86-64-linux-os.c b/src/runtime/x86-64-linux-os.c index 01e69bc..130d0c4 100644 --- a/src/runtime/x86-64-linux-os.c +++ b/src/runtime/x86-64-linux-os.c @@ -129,8 +129,11 @@ os_context_fp_addr(os_context_t *context) unsigned long os_context_fp_control(os_context_t *context) { - int mxcsr = context->uc_mcontext.fpregs->mxcsr; - return ((mxcsr & 0x3F) << 16 | ((mxcsr >> 7) & 0x3F)) ^ 0x3F; + /* return the x87 exception flags ored in with the sse2 + * control+status flags */ + unsigned int result = (context->uc_mcontext.fpregs->swd & 0x3F) | context->uc_mcontext.fpregs->mxcsr; + /* flip exception mask bits */ + return result ^ (0x3F << 7); } sigset_t * @@ -142,7 +145,11 @@ os_context_sigmask_addr(os_context_t *context) void os_restore_fp_control(os_context_t *context) { - asm ("ldmxcsr %0" : : "m" (context->uc_mcontext.fpregs->mxcsr)); + /* reset exception flags and restore control flags on SSE2 FPU */ + unsigned int temp = (context->uc_mcontext.fpregs->mxcsr) & ~0x3F; + asm ("ldmxcsr %0" : : "m" (temp)); + /* same for x87 FPU. */ + asm ("fldcw %0" : : "m" (context->uc_mcontext.fpregs->cwd)); } void diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index fab9d1f..f2a3225 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -85,7 +85,7 @@ void arch_skip_instruction(os_context_t *context) vlen = *(char*)(*os_context_pc_addr(context))++; /* Skip Lisp error arg data bytes. */ while (vlen-- > 0) { - ( (char*)(*os_context_pc_addr(context)) )++; + ++*os_context_pc_addr(context); } break; @@ -265,12 +265,12 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) break; case trap_Breakpoint: - (char*)(*os_context_pc_addr(context)) -= 1; + --*os_context_pc_addr(context); handle_breakpoint(signal, info, context); break; case trap_FunEndBreakpoint: - (char*)(*os_context_pc_addr(context)) -= 1; + --*os_context_pc_addr(context); *os_context_pc_addr(context) = (int)handle_fun_end_breakpoint(signal, info, context); break; diff --git a/version.lisp-expr b/version.lisp-expr index 3044841..2e9dbf4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.7" +"0.9.1.8" -- 1.7.10.4