A cast of NaN or an infinity to an integer says so by name, on both backends

lib/emit.ml

@@ -1517,6 +1517,8 @@ let arith_rem_zero = 1
 let arith_div_overflow = 2
 let arith_rem_overflow = 3
 let arith_cast_range = 4
+let arith_cast_nan = 5
+let arith_cast_inf = 6
 
 (* ArithError's fields are i64 and an operand may be narrower, so every
    operand is widened on the way into the condition — signed or not according
@@ -1668,11 +1670,27 @@ let check_cast f ~guard loc (src : Types.fkind) (k : Types.ikind) v =
     ins f "%s = fcmp olt double %s, %s" b v (dbl hi_f);
     let ok = fresh f in
     ins f "%s = and i1 %s, %s" ok a b;
+    (* NaN and the infinities are named rather than reported as out of range:
+       they are not values that overshot the type, they have no integer at
+       all. Worked out on the cold path, so the guard is still two compares. *)
     signal_block f loc ~guard ok (fun id nn ->
+      let nan = fresh f in
+      ins f "%s = fcmp uno double %s, %s" nan v v;
+      let pinf = fresh f in
+      ins f "%s = fcmp oeq double %s, %s" pinf v (dbl infinity);
+      let ninf = fresh f in
+      ins f "%s = fcmp oeq double %s, %s" ninf v (dbl neg_infinity);
+      let inf = fresh f in
+      ins f "%s = or i1 %s, %s" inf pinf ninf;
+      let c1 = fresh f in
+      ins f "%s = select i1 %s, i32 %d, i32 %d" c1 inf arith_cast_inf
+        arith_cast_range;
+      let code = fresh f in
+      ins f "%s = select i1 %s, i32 %d, i32 %s" code nan arith_cast_nan c1;
       ins f
-        "call void @flan_arith_error(ptr %s, i64 %d, i32 %d, i64 %Ld, i64 %Ld, \
+        "call void @flan_arith_error(ptr %s, i64 %d, i32 %s, i64 %Ld, i64 %Ld, \
          ptr %s)"
-        id nn arith_cast_range lo_i hi_i xfer_param)
+        id nn code lo_i hi_i xfer_param)
   end
 
 (* [at] is strict: the last valid index is len - 1. *)

lib/prelude.ml

@@ -123,9 +123,11 @@ let source = {flan|
 ;;   0  (/ a 0)      1  (% a 0)
 ;;   2  (/ min -1)   3  (% min -1)
 ;;   4  a float to integer cast whose value does not fit
+;;   5  a float to integer cast of NaN
+;;   6  a float to integer cast of an infinity
 ;;
 ;; `lhs` and `rhs` are the two operands for codes 0 through 3 and the
-;; destination type's representable range for code 4 — the violated condition
+;; destination type's representable range for codes 4 through 6 — the violated condition
 ;; written as a range, which is what flan_slice_promise_error already does
 ;; with BoundsError's fields. Two meanings over two fields rather than two
 ;; condition types, so that a handler writes one clause and not five. The

lib/x86.ml

@@ -2812,8 +2812,30 @@ and check_cast f (loc : Loc.t) (src : Types.fkind) (k : Types.ikind) =
       ucomis f.b ~f64 ~a:1 ~c:xmm0;
       jcc_lbl f.b ~cc:cc_a ok;
       lbl f.b bad;
+      (* Which code, on the cold path: NaN and the infinities are named rather
+         than reported as out of range. xmm0 still holds the value here. *)
+      let call = new_label f "nofitcall" and notnan = new_label f "notnan"
+      and isinf = new_label f "isinf" in
       imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_range);
       store_int f.b ~src:rax ~mm:(Frame so) ~size:8;
+      ucomis f.b ~f64 ~a:xmm0 ~c:xmm0;
+      jcc_lbl f.b ~cc:cc_np notnan;
+      imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_nan);
+      store_int f.b ~src:rax ~mm:(Frame so) ~size:8;
+      jmp_lbl f.b call;
+      lbl f.b notnan;
+      let kpinf = float_const f infinity ~f64
+      and kninf = float_const f neg_infinity ~f64 in
+      fload f.b ~dst:1 ~mm:(Sym (kpinf, 0)) ~f64;
+      ucomis f.b ~f64 ~a:xmm0 ~c:1;
+      jcc_lbl f.b ~cc:cc_e isinf;
+      fload f.b ~dst:1 ~mm:(Sym (kninf, 0)) ~f64;
+      ucomis f.b ~f64 ~a:xmm0 ~c:1;
+      jcc_lbl f.b ~cc:cc_ne call;
+      lbl f.b isinf;
+      imm_into f ~reg:rax (Int64.of_int Emit.arith_cast_inf);
+      store_int f.b ~src:rax ~mm:(Frame so) ~size:8;
+      lbl f.b call;
       imm_into f ~reg:rax lo_i;
       store_int f.b ~src:rax ~mm:(Frame sa) ~size:8;
       imm_into f ~reg:rax hi_i;

runtime/flan_rt.c

@@ -969,7 +969,9 @@ enum {
   FLAN_ARITH_REM_ZERO = 1,
   FLAN_ARITH_DIV_OVERFLOW = 2,
   FLAN_ARITH_REM_OVERFLOW = 3,
-  FLAN_ARITH_CAST_RANGE = 4
+  FLAN_ARITH_CAST_RANGE = 4,
+  FLAN_ARITH_CAST_NAN = 5,
+  FLAN_ARITH_CAST_INF = 6
 };
 
 typedef struct { int32_t op; int64_t lhs, rhs; } flan_arith_cond;
@@ -1005,6 +1007,19 @@ static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op,
             op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs,
             (long long)rhs);
     break;
+  /* NaN and the infinities did not overshoot the range: no integer is
+   * their value, whatever the type. Saying "does not fit" reads as too big. */
+  case FLAN_ARITH_CAST_NAN:
+    fprintf(stderr,
+            "%.*s: this value is NaN, which has no integer value to cast to\n",
+            (int)loclen, (const char *)loc);
+    break;
+  case FLAN_ARITH_CAST_INF:
+    fprintf(stderr,
+            "%.*s: this value is infinite, which has no integer value to cast "
+            "to\n",
+            (int)loclen, (const char *)loc);
+    break;
   default:
     fprintf(stderr,
             "%.*s: this value does not fit the integer type it is cast to, "

test/programs/arith-condition.flan

@@ -180,7 +180,8 @@
 
       ;; NaN fails both halves of the range test, which is deliberate: a NaN
       ;; cast to an integer is exactly as undefined as a value out of range,
-      ;; and an unordered comparison would have waved it through.
+      ;; and an unordered comparison would have waved it through. Its code is
+      ;; 5, which names NaN, rather than 4, which says it overshot the range.
       (cast-frame (/ (f64 0.0) (f64 0.0)))
       (show "op" (i64 op))
 

test/programs/arith.flan

@@ -76,6 +76,12 @@
       ;; double there, which agree because every bound is a power of two and is
       ;; exact in both.
       (= n 9) (print (i32 wide))
+      ;; NaN and the infinities have no integer value at all, so the message
+      ;; names them rather than a range they did not overshoot. An f32 source
+      ;; for each too, since the two backends test it at different widths.
+      (= n 10) (print (i32 (/ (f64 1.0) (f64 0.0))))
+      (= n 11) (print (u8 (/ (f32 -1.0) (f32 0.0))))
+      (= n 12) (print (i32 (/ (f32 0.0) (f32 0.0))))
 
       :else (println "?"))
     0))

test/test_acceptance.ml

@@ -2543,8 +2543,8 @@ let () =
        no overflow case because it has no most-negative value, and a float
        division by zero, which is an infinity and is a defined answer this
        language has no business refusing. *)
-    let arith ?opt () =
+    let arith ?opt ?x86 () =
-      let exe = compile ?opt "programs/arith.flan" in
+      let exe = compile ?opt ?x86 "programs/arith.flan" in
       let traps name arg reason =
         let code, text = run exe (Some arg) in
         if code <> 134
@@ -2587,7 +2587,7 @@ let () =
          would have waved it through into an fptosi that is as undefined for a
          NaN as it is for 1e300. *)
       traps "NaN cast to an integer" "7"
-        "does not fit the integer type it is cast to";
+        "this value is NaN, which has no integer value to cast to";
       (* One width down, and this is the case the two backends disagreed about
          *silently* rather than both dying: x86 loaded the operands
          sign-extended into 64-bit registers, divided there and truncated on
@@ -2604,10 +2604,21 @@ let () =
          and this is the row that says so rather than the comment. *)
       traps "an f32 too large for an i32" "9"
         "which holds [-2147483648 2147483647]";
+      (* NaN and the infinities are named: they did not overshoot a range,
+         they have no integer value at all. *)
+      traps "an infinity cast to an integer" "10"
+        "this value is infinite, which has no integer value to cast to";
+      traps "an f32 negative infinity cast to a u8" "11"
+        "this value is infinite, which has no integer value to cast to";
+      traps "an f32 NaN cast to an integer" "12"
+        "this value is NaN, which has no integer value to cast to";
       (try Sys.remove exe with Sys_error _ -> ())
     in
     arith ();
     arith ~opt:"-O0" ();
+    (* The x86 backend picks the code with its own instructions, so the three
+       named cases are asserted there as well as in the survey. *)
+    arith ~x86:true ();
 
     (* The release build drops the guards. Asserted on the IR and not by
        running an unchecked program, for the reason the bounds case gives: an
@@ -2646,7 +2657,7 @@ let () =
        op 2\nlhs -9223372036854775808\nrhs -1\nop 3\n\
        cast 3\ncast -3\n\
        op 4\nlhs -9223372036854775808\nrhs 9223372036854775807\nop 4\n\
-       cast8 12\nlhs -128\nrhs 127\nop 4\n\
+       cast8 12\nlhs -128\nrhs 127\nop 5\n\
        lit 4611686018427387903\nu 14\n\
        frames 4\nskipped 8\ncleaned 12\n"
     in