flambda-backend: float32 literals (#2434)

bytecomp/bytegen.ml

@@ -1014,7 +1014,7 @@ let rec comp_expr stack_info env exp sz cont =
         | CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont
       in
       comp_args stack_info env args sz cont
-  | Lprim (Pfloatcomp (Pfloat32, cmp), args, _) ->
+  | Lprim (Pfloatcomp (Pfloat32, cmp), args, _) | Lprim (Punboxed_float_comp (Pfloat32, cmp), args, _) ->
       let cont =
         match cmp with
         | CFeq -> Kccall("caml_eq_float32", 2) :: cont

lambda/matching.ml

@@ -2892,9 +2892,8 @@ let combine_constant value_kind loc arg cst partial ctx def
           (Pfloatcomp (Pfloat64, CFlt)) arg
           const_lambda_list
     | Const_float32 _ ->
-        make_test_sequence value_kind loc fail (Pfloatcomp (Pfloat32, CFneq))
-        (Pfloatcomp (Pfloat32, CFlt)) arg
-          const_lambda_list
+        (* Should be caught in do_compile_matching. *)
+        Misc.fatal_error "Found unexpected float32 literal pattern."
     | Const_unboxed_float _ ->
         make_test_sequence value_kind loc fail
           (Punboxed_float_comp (Pfloat64, CFneq))
@@ -3568,6 +3567,7 @@ and do_compile_matching ~scopes value_kind repr partial ctx pmh =
           compile_no_test ~scopes value_kind
             (divide_record ~scopes lbl.lbl_all ph)
             Context.combine repr partial ctx pm
+      | Constant (Const_float32 _) -> Parmatch.raise_matched_float32 ()
       | Constant cst ->
           compile_test
             (compile_match ~scopes value_kind repr partial)

testsuite/tests/typing-small-numbers/test_disabled.ml

@@ -10,3 +10,110 @@ Line 1, characters 9-16:
 Error: Unbound type constructor float32
 Hint: Did you mean float, float# or float32x4?
 |}];;
+
+let _ = 1.0s;;
+[%%expect{|
+Line 1, characters 8-12:
+1 | let _ = 1.0s;;
+            ^^^^
+Error: Found 32-bit float literal 1.0s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 1.s;;
+[%%expect{|
+Line 1, characters 8-11:
+1 | let _ = 1.s;;
+            ^^^
+Error: Found 32-bit float literal 1.s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 1e10s;;
+[%%expect{|
+Line 1, characters 8-13:
+1 | let _ = 1e10s;;
+            ^^^^^
+Error: Found 32-bit float literal 1e10s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 1e+1s;;
+[%%expect{|
+Line 1, characters 8-13:
+1 | let _ = 1e+1s;;
+            ^^^^^
+Error: Found 32-bit float literal 1e+1s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 1e-1s;;
+[%%expect{|
+Line 1, characters 8-13:
+1 | let _ = 1e-1s;;
+            ^^^^^
+Error: Found 32-bit float literal 1e-1s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 0x111.000s;;
+[%%expect{|
+Line 1, characters 8-18:
+1 | let _ = 0x111.000s;;
+            ^^^^^^^^^^
+Error: Found 32-bit float literal 0x111.000s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 0x1.4p+0s;;
+[%%expect{|
+Line 1, characters 8-17:
+1 | let _ = 0x1.4p+0s;;
+            ^^^^^^^^^
+Error: Found 32-bit float literal 0x1.4p+0s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 0xf.ffffffffffff8p+1020s;;
+[%%expect{|
+Line 1, characters 8-32:
+1 | let _ = 0xf.ffffffffffff8p+1020s;;
+            ^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Found 32-bit float literal 0xf.ffffffffffff8p+1020s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 0x8p-972s;;
+[%%expect{|
+Line 1, characters 8-17:
+1 | let _ = 0x8p-972s;;
+            ^^^^^^^^^
+Error: Found 32-bit float literal 0x8p-972s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = 0xc.d5e6fp+1_24s;;
+[%%expect{|
+Line 1, characters 8-24:
+1 | let _ = 0xc.d5e6fp+1_24s;;
+            ^^^^^^^^^^^^^^^^
+Error: Found 32-bit float literal 0xc.d5e6fp+1_24s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let () =
+  match 0.0s with
+  | _ -> ()
+;;
+[%%expect{|
+Line 2, characters 8-12:
+2 |   match 0.0s with
+            ^^^^
+Error: Found 32-bit float literal 0.0s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = #1.0s;;
+[%%expect{|
+Line 1, characters 8-13:
+1 | let _ = #1.0s;;
+            ^^^^^
+Error: Found 32-bit float literal #1.0s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;
+
+let _ = -#1.0s;;
+[%%expect{|
+Line 1, characters 8-14:
+1 | let _ = -#1.0s;;
+            ^^^^^^
+Error: Found 32-bit float literal -#1.0s, but float32 is not enabled. You must enable -extension small_numbers to use this feature.
+|}];;

testsuite/tests/typing-small-numbers/test_enabled.ml

@@ -3,7 +3,97 @@
  expect;
 *)
 
+(* Operations are tested in tests/small_numbers/float32.ml *)
+
 type t = float32;;
 [%%expect{|
 type t = float32
 |}];;
+
+let _ : float32 = 1.0s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 1.s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 1e10s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 1e+1s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 1e-1s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 0x111.000s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 0x1.4p+0s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 0xf.ffffffffffff8p+1020s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 0x8p-972s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+let _ : float32 = 0xc.d5e6fp+1_24s;;
+[%%expect{|
+- : float32 = <abstr>
+|}];;
+
+(* A (trivial) match with no float32 cases is allowed. *)
+let () =
+  match 0.0s with
+  | _ -> ()
+;;
+[%%expect{|
+|}];;
+
+let () =
+  match 0.0s with
+  | 0.0s -> ()
+  | _ -> ()
+;;
+[%%expect{|
+Line 1:
+Error: float32 literal patterns are not supported.
+|}];;
+
+let () =
+  match 0.0s with
+  | 0.0s -> ()
+  | 1.0s -> ()
+  | _ -> ()
+;;
+[%%expect{|
+Line 1:
+Error: float32 literal patterns are not supported.
+|}];;
+
+let () =
+  match 0.0s with
+  | 0.0s -> ()
+;;
+[%%expect{|
+Line 1:
+Error: float32 literal patterns are not supported.
+|}];;

typing/parmatch.ml

@@ -20,6 +20,12 @@ open Asttypes
 open Types
 open Typedtree
 
+type error = Float32_match
+
+exception Error of error
+
+let raise_matched_float32 () = raise (Error Float32_match)
+
 type 'pattern parmatch_case =
   { pattern : 'pattern;
     has_guard : bool;
@@ -271,13 +277,15 @@ let const_compare x y =
   | Const_unboxed_float f1, Const_unboxed_float f2
   | Const_float f1, Const_float f2 ->
       Stdlib.compare (float_of_string f1) (float_of_string f2)
+  | Const_float32 _, _ ->
+      (* CR mslater: (float32) pattern matching (needs float32 lib) *)
+      raise_matched_float32 ()
   | Const_string (s1, _, _), Const_string (s2, _, _) ->
       String.compare s1 s2
   | (Const_int _
     |Const_char _
     |Const_string (_, _, _)
     |Const_float _
-    |Const_float32 _
     |Const_unboxed_float _
     |Const_int32 _
     |Const_int64 _
@@ -1102,6 +1110,9 @@ let build_other ext env =
                     | _ -> assert false)
             (function f -> Tpat_constant(Const_float (string_of_float f)))
             0.0 (fun f -> f +. 1.0) d env
+      | Constant Const_float32 _ ->
+          (* CR mslater: (float32) pattern matching (needs float32 lib) *)
+          raise_matched_float32 ()
       | Constant Const_unboxed_float _ ->
           build_other_constant
             (function Constant(Const_unboxed_float f) -> float_of_string f
@@ -2454,3 +2465,11 @@ let check_ambiguous_bindings =
             ns
       in
       ignore (List.fold_left check_case [] cases)
+
+let report_error ppf = function
+  | Float32_match -> Format.pp_print_string ppf "float32 literal patterns are not supported."
+
+let () =
+  Location.register_error_of_exn (function
+    | Error err -> Some (Location.error_of_printer_file report_error err)
+    | _ -> None)

typing/parmatch.mli

@@ -135,3 +135,6 @@ val check_ambiguous_bindings : value case list -> unit
 
 (* The tag used for open polymorphic variant types with an abstract row *)
 val some_private_tag : label
+
+(* Raise an error due to matching on a float32. *)
+val raise_matched_float32 : unit -> 'a

typing/typecore.ml

@@ -202,6 +202,7 @@ type error =
   | Extension_not_enabled : _ Language_extension.t -> error
   | Literal_overflow of string
   | Unknown_literal of string * char
+  | Float32_literal of string
   | Illegal_letrec_pat
   | Illegal_letrec_expr
   | Illegal_class_expr
@@ -680,6 +681,9 @@ let constant : Parsetree.constant -> (Typedtree.constant, error) result =
   | Pconst_char c -> Ok (Const_char c)
   | Pconst_string (s,loc,d) -> Ok (Const_string (s,loc,d))
   | Pconst_float (f,None)-> Ok (Const_float f)
+  | Pconst_float (f,Some 's') ->
+    if Language_extension.is_enabled Small_numbers then Ok (Const_float32 f)
+    else Error (Float32_literal f)
   | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c))
 
 let constant_or_raise env loc cst =
@@ -690,7 +694,12 @@ let constant_or_raise env loc cst =
 let unboxed_constant : Jane_syntax.Layouts.constant -> (Typedtree.constant, error) result
   = function
   | Float (f, None) -> Ok (Const_unboxed_float f)
-  | Float (x, Some c) -> Error (Unknown_literal (Misc.format_as_unboxed_literal x, c))
+  | Float (f, Some 's') ->
+    (* CR mslater: (float32) unboxed *)
+    if Language_extension.is_enabled Small_numbers then assert false
+    else Error (Float32_literal (Misc.format_as_unboxed_literal f))
+  | Float (x, Some c) ->
+    Error (Unknown_literal (Misc.format_as_unboxed_literal x, c))
   | Integer (i, suffix) ->
     begin match constant_integer i ~suffix with
       | Ok (Int32 v) -> Ok (Const_unboxed_int32 v)
@@ -10079,6 +10088,9 @@ let report_error ~loc env = function
         ty
   | Unknown_literal (n, m) ->
       Location.errorf ~loc "Unknown modifier '%c' for literal %s%c" m n m
+  | Float32_literal f ->
+      Location.errorf ~loc "Found 32-bit float literal %ss, but float32 is not enabled. \
+                            You must enable -extension small_numbers to use this feature." f
   | Illegal_letrec_pat ->
       Location.errorf ~loc
         "Only variables are allowed as left-hand side of `let rec'"

typing/typecore.mli

@@ -268,6 +268,7 @@ type error =
   | Extension_not_enabled : _ Language_extension.t -> error
   | Literal_overflow of string
   | Unknown_literal of string * char
+  | Float32_literal of string
   | Illegal_letrec_pat
   | Illegal_letrec_expr
   | Illegal_class_expr
@@ -330,4 +331,4 @@ val check_recursive_bindings : Env.t -> Typedtree.value_binding list -> unit
 val check_recursive_class_bindings :
   Env.t -> Ident.t list -> Typedtree.class_expr list -> unit
 
-val src_pos : Location.t -> Typedtree.attributes -> Env.t -> Typedtree.expression 
+val src_pos : Location.t -> Typedtree.attributes -> Env.t -> Typedtree.expression

typing/typeopt.ml

@@ -740,6 +740,7 @@ let classify_lazy_argument : Typedtree.expression ->
   fun e -> match e.exp_desc with
     | Texp_constant
         ( Const_int _ | Const_char _ | Const_string _
+        | Const_float32 _ (* There is no float32 array optimization *)
         | Const_int32 _ | Const_int64 _ | Const_nativeint _ )
     | Texp_function _
     | Texp_construct (_, {cstr_arity = 0}, _, _) ->