diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 429c5df87..95f385a7c 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. -#!-(or alpha x86-64) +#!-(or alpha x86-64 mips) (progn (defun floating-point-modes () (floating-point-modes)) diff --git a/src/code/float.lisp b/src/code/float.lisp index 9e8ae74ab..a8dd5f0f2 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -75,19 +75,34 @@ (!define-float-dispatching-function float-nan-p "Return true if the float X is a NaN (Not a Number)." + #!-(or mips hppa) (not (zerop (ldb sb!vm:single-float-significand-byte bits))) + #!+(or mips hppa) + (zerop (logand (ldb sb!vm:single-float-significand-byte bits) + sb!vm:single-float-trapping-nan-bit)) + #!-(or mips hppa) (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) (not (zerop lo))) + #!+(or mips hppa) + (zerop (logand (ldb sb!vm:double-float-significand-byte hi) + sb!vm:double-float-trapping-nan-bit)) #!+(and long-float x86) (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) (not (zerop lo)))) (!define-float-dispatching-function float-trapping-nan-p "Return true if the float X is a trapping NaN (Not a Number)." + #!-(or mips hppa) (zerop (logand (ldb sb!vm:single-float-significand-byte bits) sb!vm:single-float-trapping-nan-bit)) + #!+(or mips hppa) + (not (zerop (ldb sb!vm:single-float-significand-byte bits))) + #!-(or mips hppa) (zerop (logand (ldb sb!vm:double-float-significand-byte hi) sb!vm:double-float-trapping-nan-bit)) + #!+(or mips hppa) + (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) + (not (zerop lo))) #!+(and long-float x86) (zerop (logand (ldb sb!vm:long-float-significand-byte hi) sb!vm:long-float-trapping-nan-bit))) diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 5f901c910..65c96f152 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -211,6 +211,7 @@ (when (zerop (logior y-ihi y-lo)) (return-from real-expt (coerce 1d0 rtype))) ;; +-NaN return x+y + ;; FIXME: Hardcoded qNaN/sNaN values are not portable. (when (or (> x-ihi #x7ff00000) (and (= x-ihi #x7ff00000) (/= x-lo 0)) (> y-ihi #x7ff00000) diff --git a/src/code/mips-vm.lisp b/src/code/mips-vm.lisp index 987dc6b02..b3c44b232 100644 --- a/src/code/mips-vm.lisp +++ b/src/code/mips-vm.lisp @@ -94,6 +94,14 @@ (declare (type (alien (* os-context-register-t)) addr)) (setf (deref addr) (coerce new format)))) +(define-alien-routine + ("arch_get_fp_control" floating-point-modes) unsigned-int) + +(define-alien-routine + ("arch_set_fp_control" %floating-point-modes-setter) void (fp unsigned-int)) + +(defun (setf floating-point-modes) (val) (%floating-point-modes-setter val)) + ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. (define-alien-routine ("os_context_fp_control" context-floating-point-modes) diff --git a/src/compiler/mips/float.lisp b/src/compiler/mips/float.lisp index 61113c916..1f406c573 100644 --- a/src/compiler/mips/float.lisp +++ b/src/compiler/mips/float.lisp @@ -692,35 +692,6 @@ (inst mfc1 lo-bits float) (inst nop))) - -;;;; Float mode hackery: - -;#| -(sb!xc:deftype float-modes () '(unsigned-byte 32)) -(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) - (:generator 3 - (inst cfc1 res 31) - (inst nop))) - -(define-vop (set-floating-point-modes) - (:args (new :scs (unsigned-reg) :target res)) - (:results (res :scs (unsigned-reg))) - (:arg-types unsigned-num) - (:result-types unsigned-num) - (:translate (setf floating-point-modes)) - (:policy :fast-safe) - (:generator 3 - (inst ctc1 new 31) - (move res new))) -;|# ;;;; Complex float VOPs diff --git a/src/compiler/mips/parms.lisp b/src/compiler/mips/parms.lisp index 193200423..5d6f495b5 100644 --- a/src/compiler/mips/parms.lisp +++ b/src/compiler/mips/parms.lisp @@ -52,6 +52,7 @@ (def!constant float-overflow-trap-bit (ash 1 2)) (def!constant float-divide-by-zero-trap-bit (ash 1 3)) (def!constant float-invalid-trap-bit (ash 1 4)) +(def!constant float-unimplemented-trap-bit (ash 1 5)) (def!constant float-round-to-nearest 0) (def!constant float-round-to-zero 1) @@ -61,7 +62,7 @@ (defconstant-eqx float-rounding-mode (byte 2 0) #'equalp) (defconstant-eqx float-sticky-bits (byte 5 2) #'equalp) (defconstant-eqx float-traps-byte (byte 5 7) #'equalp) -(defconstant-eqx float-exceptions-byte (byte 5 12) #'equalp) +(defconstant-eqx float-exceptions-byte (byte 6 12) #'equalp) (defconstant-eqx float-condition-bit (ash 1 23) #'equalp) (def!constant float-fast-bit (ash 1 24)) diff --git a/src/runtime/mips-arch.c b/src/runtime/mips-arch.c index ad7d8339d..b33b1185e 100644 --- a/src/runtime/mips-arch.c +++ b/src/runtime/mips-arch.c @@ -400,6 +400,9 @@ sigtrap_handler(int signal, siginfo_t *info, void *void_context) { os_context_t *context = arch_os_get_context(&void_context); unsigned int code = (os_context_insn(context) >> 6) & 0xfffff; +#ifdef LISP_FEATURE_LINUX + os_restore_fp_control(context); +#endif /* FIXME: This magic number is pseudo-atomic-trap from parms.lisp. * Genesis should provide the proper #define, but it specialcases * pseudo-atomic-trap to work around some oddity on SPARC. @@ -422,6 +425,9 @@ sigfpe_handler(int signal, siginfo_t *info, void *void_context) unsigned int op, rs, rt, rd, funct, dest = 32; int immed; int result; +#ifdef LISP_FEATURE_LINUX + os_restore_fp_control(context); +#endif op = (bad_inst >> 26) & 0x3f; rs = (bad_inst >> 21) & 0x1f; @@ -473,6 +479,22 @@ sigfpe_handler(int signal, siginfo_t *info, void *void_context) arch_skip_instruction(context); } +unsigned int +arch_get_fp_control(void) +{ + register unsigned int ret asm("$2"); + + __asm__ __volatile__ ("cfc1 %0, $31" : "=r" (ret)); + + return ret; +} + +void +arch_set_fp_control(unsigned int fp) +{ + __asm__ __volatile__ ("ctc1 %0, $31" :: "r" (fp)); +} + void arch_install_interrupt_handlers(void) { diff --git a/src/runtime/mips-arch.h b/src/runtime/mips-arch.h index ec8038133..4ac1b787b 100644 --- a/src/runtime/mips-arch.h +++ b/src/runtime/mips-arch.h @@ -57,4 +57,7 @@ release_spinlock(volatile lispobj *word) #endif } +unsigned int arch_get_fp_control(void); +void arch_set_fp_control(unsigned int fp); + #endif /* _MIPS_ARCH_H */ diff --git a/src/runtime/mips-linux-os.c b/src/runtime/mips-linux-os.c index 165fc2984..70f988e8f 100644 --- a/src/runtime/mips-linux-os.c +++ b/src/runtime/mips-linux-os.c @@ -80,14 +80,17 @@ os_context_sigmask_addr(os_context_t *context) unsigned int os_context_fp_control(os_context_t *context) { - /* FIXME: Probably do something. */ - return 0; + mcontext_t *mctx = &context->uc_mcontext; + struct sigcontext *ctx = (struct sigcontext *)mctx; + return ctx->sc_fpc_csr; } void os_restore_fp_control(os_context_t *context) { - /* FIXME: Probably do something. */ + unsigned int ctl = os_context_fp_control(context); + ctl &= ~(FLOAT_STICKY_BITS_MASK | FLOAT_EXCEPTIONS_BYTE_MASK); + arch_set_fp_control(ctl); } unsigned int diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index f532cfef7..a2b2c35fe 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -159,7 +159,7 @@ (with-test (:name :nan-comparisons - :fails-on (or :x86-64 :sparc)) + :fails-on (or :x86-64 :sparc :mips)) (sb-int:with-float-traps-masked (:invalid) (macrolet ((test (form) (let ((nform (subst '(/ 0.0 0.0) 'nan form))) diff --git a/version.lisp-expr b/version.lisp-expr index 525d12dcc..9f7de9a84 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".) -"1.0.8.35" +"1.0.8.36"