squash for review

Author: TheNumbat

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -53,6 +53,7 @@ type close_functions_result =
 type declare_const_result =
   | Field of Field_of_static_block.t
   | Unboxed_float of Numeric_types.Float_by_bit_pattern.t
+  | Unboxed_float32 of Numeric_types.Float32_by_bit_pattern.t
   | Unboxed_int32 of Numeric_types.Int32.t
   | Unboxed_int64 of Numeric_types.Int64.t
   | Unboxed_nativeint of Targetint_32_64.t
@@ -111,8 +112,11 @@ let rec declare_const acc (const : Lambda.structured_constant) :
   | Const_base (Const_char c) ->
     acc, Field (Tagged_immediate (Targetint_31_63.of_char c)), "char"
   | Const_base (Const_unboxed_float c) ->
-    let c = Numeric_types.Float_by_bit_pattern.create (float_of_string c) in
+    let c = Numeric_types.Float_by_bit_pattern.of_string c in
     acc, Unboxed_float c, "unboxed_float"
+  | Const_base (Const_unboxed_float32 c) ->
+    let c = Numeric_types.Float32_by_bit_pattern.of_string c in
+    acc, Unboxed_float32 c, "unboxed_float32"
   | Const_base (Const_string (s, _, _)) ->
     register_const acc (SC.immutable_string s) "immstring"
   | Const_base (Const_float c) ->
@@ -165,8 +169,8 @@ let rec declare_const acc (const : Lambda.structured_constant) :
           let acc, f, _ = declare_const acc c in
           match f with
           | Field f -> acc, f
-          | Unboxed_float _ | Unboxed_int32 _ | Unboxed_int64 _
-          | Unboxed_nativeint _ ->
+          | Unboxed_float _ | Unboxed_float32 _ | Unboxed_int32 _
+          | Unboxed_int64 _ | Unboxed_nativeint _ ->
             Misc.fatal_errorf
               "Unboxed constants are not allowed inside of Const_block: %a"
               Printlambda.structured_constant const)
@@ -190,6 +194,11 @@ let close_const0 acc (const : Lambda.structured_constant) =
       Simple.const (Reg_width_const.naked_float f),
       name,
       Flambda_kind.With_subkind.naked_float )
+  | Unboxed_float32 f ->
+    ( acc,
+      Simple.const (Reg_width_const.naked_float32 f),
+      name,
+      Flambda_kind.With_subkind.naked_float32 )
   | Unboxed_int32 i ->
     ( acc,
       Simple.const (Reg_width_const.naked_int32 i),

middle_end/flambda2/to_cmm/to_cmm_shared.ml

@@ -51,7 +51,8 @@ let machtype_of_kind (kind : Flambda_kind.With_subkind.t) =
     | Immediate_array | Unboxed_int32_array | Unboxed_int64_array
     | Unboxed_nativeint_array | Value_array | Generic_array ->
       Cmm.typ_val)
-  | Naked_number (Naked_float | Naked_float32) -> Cmm.typ_float
+  | Naked_number Naked_float -> Cmm.typ_float
+  | Naked_number Naked_float32 -> Cmm.typ_float32
   | Naked_number Naked_vec128 -> Cmm.typ_vec128
   | Naked_number (Naked_immediate | Naked_int32 | Naked_int64 | Naked_nativeint)
     ->
@@ -68,7 +69,8 @@ let extended_machtype_of_kind (kind : Flambda_kind.With_subkind.t) =
     | Immediate_array | Unboxed_int32_array | Unboxed_int64_array
     | Unboxed_nativeint_array | Value_array | Generic_array ->
       Extended_machtype.typ_val)
-  | Naked_number (Naked_float32 | Naked_float) -> Extended_machtype.typ_float
+  | Naked_number Naked_float -> Extended_machtype.typ_float
+  | Naked_number Naked_float32 -> Extended_machtype.typ_float32
   | Naked_number Naked_vec128 -> Extended_machtype.typ_vec128
   | Naked_number (Naked_immediate | Naked_int32 | Naked_int64 | Naked_nativeint)
     ->

ocaml/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.machtype_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

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

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

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

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

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

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

ocaml/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 _) ->

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

ocaml/otherlibs/alpha/alpha.ml

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

ocaml/otherlibs/alpha/alpha.mli

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

ocaml/otherlibs/alpha/dune

@@ -42,13 +42,18 @@
   (alpha.cma as alpha/alpha.cma)
   (alpha.mli as alpha/alpha.mli)
   (float32.mli as alpha/float32.mli)
+  (float32_u.mli as alpha/float32_u.mli)
   (.alpha.objs/byte/alpha.cmi as alpha/alpha.cmi)
   (.alpha.objs/byte/alpha.cmt as alpha/alpha.cmt)
   (.alpha.objs/byte/alpha.cmti as alpha/alpha.cmti)
   (.alpha.objs/native/alpha.cmx as alpha/alpha.cmx)
   (.alpha.objs/byte/float32.cmi as alpha/float32.cmi)
   (.alpha.objs/byte/float32.cmt as alpha/float32.cmt)
   (.alpha.objs/byte/float32.cmti as alpha/float32.cmti)
-  (.alpha.objs/native/float32.cmx as alpha/float32.cmx))
+  (.alpha.objs/native/float32.cmx as alpha/float32.cmx)
+  (.alpha.objs/byte/float32_u.cmi as alpha/float32_u.cmi)
+  (.alpha.objs/byte/float32_u.cmt as alpha/float32_u.cmt)
+  (.alpha.objs/byte/float32_u.cmti as alpha/float32_u.cmti)
+  (.alpha.objs/native/float32_u.cmx as alpha/float32_u.cmx))
  (section lib)
  (package ocaml))