flambda-backend: unboxed float32 (#2520)

* squash for review

* address comments

Author: TheNumbat

asmcomp/cmmgen.ml

@@ -363,13 +363,15 @@ let exttype_of_sort (s : Jkind.Sort.const) =
   | Bits32 -> XInt32
   | Bits64 -> XInt64
   | Void -> Misc.fatal_error "Cmmgen.exttype_of_sort: void encountered"
+  | Float32 -> Misc.fatal_error "Cmmgen.exttype_of_sort: float32 encountered"
 
 let machtype_of_sort (s : Jkind.Sort.const) =
   match s with
   | Value -> typ_val
   | Float64 -> typ_float
   | Word | Bits32 | Bits64 -> typ_int
   | Void -> Misc.fatal_error "Cmmgen.machtype_of_sort: void encountered"
+  | Float32 -> Misc.fatal_error "Cmmgen.machtype_of_sort: float32 encountered"
 
 let is_unboxed_number_cmm ~strict cmm =
   let r = ref No_result in

bytecomp/symtable.ml

@@ -152,7 +152,8 @@ let rec transl_const = function
     Const_base(Const_int i) -> Obj.repr i
   | Const_base(Const_char c) -> Obj.repr c
   | Const_base(Const_string (s, _, _)) -> Obj.repr s
-  | Const_base(Const_float32 f) -> float32_of_string f
+  | Const_base(Const_float32 f)
+  | Const_base(Const_unboxed_float32 f) -> float32_of_string f
   | Const_base(Const_float f)
   | Const_base(Const_unboxed_float f) -> Obj.repr (float_of_string f)
   | Const_base(Const_int32 i)

lambda/lambda.ml

@@ -1748,6 +1748,7 @@ let constant_layout: constant -> layout = function
   | Const_float _ -> Pvalue (Pboxedfloatval Pfloat64)
   | Const_float32 _ -> Pvalue (Pboxedfloatval Pfloat32)
   | Const_unboxed_float _ -> Punboxed_float Pfloat64
+  | Const_unboxed_float32 _ -> Punboxed_float Pfloat32
 
 let structured_constant_layout = function
   | Const_base const -> constant_layout const
@@ -1763,6 +1764,7 @@ let layout_of_extern_repr : extern_repr -> _ = function
     begin match s with
     | Value -> layout_any_value
     | Float64 -> layout_unboxed_float Pfloat64
+    | Float32 -> layout_unboxed_float Pfloat32
     | Word -> layout_unboxed_nativeint
     | Bits32 -> layout_unboxed_int32
     | Bits64 -> layout_unboxed_int64

lambda/matching.ml

@@ -1160,6 +1160,7 @@ let can_group discr pat =
   | Constant (Const_float _), Constant (Const_float _)
   | Constant (Const_float32 _), Constant (Const_float32 _)
   | Constant (Const_unboxed_float _), Constant (Const_unboxed_float _)
+  | Constant (Const_unboxed_float32 _), Constant (Const_unboxed_float32 _)
   | Constant (Const_int32 _), Constant (Const_int32 _)
   | Constant (Const_int64 _), Constant (Const_int64 _)
   | Constant (Const_nativeint _), Constant (Const_nativeint _)
@@ -1186,9 +1187,10 @@ let can_group discr pat =
       ( Any
       | Constant
           ( Const_int _ | Const_char _ | Const_string _ | Const_float _
-          | Const_float32 _ | Const_unboxed_float _ | Const_int32 _
-          | Const_int64 _ | Const_nativeint _ | Const_unboxed_int32 _
-          | Const_unboxed_int64 _ | Const_unboxed_nativeint _ )
+          | Const_float32 _ | Const_unboxed_float _ | Const_unboxed_float32 _
+          | Const_int32 _ | Const_int64 _ | Const_nativeint _
+          | Const_unboxed_int32 _ | Const_unboxed_int64 _
+          | Const_unboxed_nativeint _ )
       | Construct _ | Tuple _ | Record _ | Array _ | Variant _ | Lazy ) ) ->
       false
 
@@ -2891,7 +2893,7 @@ let combine_constant value_kind loc arg cst partial ctx def
         make_test_sequence value_kind loc fail (Pfloatcomp (Pfloat64, CFneq))
           (Pfloatcomp (Pfloat64, CFlt)) arg
           const_lambda_list
-    | Const_float32 _ ->
+    | Const_float32 _ | Const_unboxed_float32 _ ->
         (* Should be caught in do_compile_matching. *)
         Misc.fatal_error "Found unexpected float32 literal pattern."
     | Const_unboxed_float _ ->
@@ -3567,7 +3569,8 @@ 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 (Const_float32 _ | Const_unboxed_float32 _) ->
+          Parmatch.raise_matched_float32 ()
       | Constant cst ->
           compile_test
             (compile_match ~scopes value_kind repr partial)

lambda/printlambda.ml

@@ -25,9 +25,11 @@ let rec struct_const ppf = function
   | Const_base(Const_string (s, _, _)) -> fprintf ppf "%S" s
   | Const_immstring s -> fprintf ppf "#%S" s
   | Const_base(Const_float f) -> fprintf ppf "%s" f
-  | Const_base(Const_float32 f) -> fprintf ppf "%s" f
+  | Const_base(Const_float32 f) -> fprintf ppf "%ss" f
   | Const_base(Const_unboxed_float f) ->
       fprintf ppf "%s" (Misc.format_as_unboxed_literal f)
+  | Const_base(Const_unboxed_float32 f) ->
+      fprintf ppf "%ss" (Misc.format_as_unboxed_literal f)
   | Const_base(Const_int32 n) -> fprintf ppf "%lil" n
   | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
   | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n

lambda/translcore.ml

@@ -56,6 +56,9 @@ let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type
 let check_record_field_sort loc sort =
   match Jkind.Sort.get_default_value sort with
   | Value | Float64 | Bits32 | Bits64 | Word -> ()
+  | Float32 ->
+    (* CR mslater: (float32) float32# records *)
+    Misc.fatal_error "Found unboxed float32 record field."
   | Void -> raise (Error (loc, Illegal_void_record_field))
 
 (* Forward declaration -- to be filled in by Translmod.transl_module *)

lambda/translprim.ml

@@ -700,9 +700,10 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
     | "%obj_magic" -> Primitive(Pobj_magic layout, 1)
     | "%array_to_iarray" -> Primitive (Parray_to_iarray, 1)
     | "%array_of_iarray" -> Primitive (Parray_of_iarray, 1)
-    (* CR mslater: (float32) unboxed *)
     | "%unbox_float" -> Primitive(Punbox_float Pfloat64, 1)
     | "%box_float" -> Primitive(Pbox_float (Pfloat64, mode), 1)
+    | "%unbox_float32" -> Primitive(Punbox_float Pfloat32, 1)
+    | "%box_float32" -> Primitive(Pbox_float (Pfloat32, mode), 1)
     | "%get_header" -> Primitive (Pget_header mode, 1)
     | "%atomic_load" ->
         Primitive ((Patomic_load {immediate_or_pointer=Pointer}), 1)

middle_end/closure/closure.ml

@@ -1027,7 +1027,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env)
         | Const_base (Const_string (s, _, _)) ->
             str (Uconst_string s)
         | Const_base(Const_float x) -> str (Uconst_float (float_of_string x))
-        | Const_base(Const_float32 _) ->
+        | Const_base(Const_float32 _ | Const_unboxed_float32 _) ->
             Misc.fatal_error "float32 is not supported in closure. Consider using flambda2."
         | Const_base (Const_unboxed_float _ | Const_unboxed_int32 _
                      | Const_unboxed_int64 _ | Const_unboxed_nativeint _) ->

middle_end/flambda/closure_conversion.ml

@@ -137,8 +137,8 @@ let rec declare_const t (const : Lambda.structured_constant)
     register_const t
       (Allocated_const (Float (float_of_string c)))
       Names.const_float
-  | Const_base (Const_float32 _) ->
-      Misc.fatal_error "float32 is not supported in closure. Consider using flambda2."
+  | Const_base (Const_float32 _ | Const_unboxed_float32 _) ->
+      Misc.fatal_error "float32 is not supported in flambda. Consider using flambda2."
   | Const_base (Const_int32 c) ->
     register_const t (Allocated_const (Int32 c))
       Names.const_int32

otherlibs/alpha/alpha.ml

@@ -1 +1,2 @@
 module Float32 = Float32
+module Float32_u = Float32_u