* 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
;;; 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))
#!-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")
(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))
+
\f
;;;; INTERNAL-ERROR-ARGS
(: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)
(inst shr lo-bits 32)))
\f
-;;;; 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)))
-\f
;;;; complex float VOPs
(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))
(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
\f
;;;; description of the target address space
(:generator 4
(inst movss (make-ea :dword :base sap :disp offset) value)
(move result value)))
-\f
-;;;; 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)))))
\f
;;; noise to convert normal lisp data objects into SAPs
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;
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;
}
#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));
+}
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 *
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
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;
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;
;;; 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"
projects / sbcl.git / commitdiff