1.0.8.36: Improve MIPS (and HPPA) floating pooint support.

  - For MIPS/HPPA, the NaN signalling bit's meaning is inverted.
  - Implement FLOATING-POINT-MODES and SET-FLOATING-POINT-MODES in C.
  - Delete the corresponding VOPs.
  - Document the MIPS special "unimplemented" floating point trap.
  - Add handling of the floating point control word in C signal handlers.
  - Mark NAN-COMPARISIONS as expected failure on MIPS. (It still doesn't
    work due to a kernel bug, siginfo_t's si_code field doesn't get
    updated properly.)

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))

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)))

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)

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)

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
 

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))
 

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)
 {

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 */

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

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)))

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"