flambda-backend: float32 flambda2 support (#2362)

Author: TheNumbat

Makefile.common-jst

@@ -268,6 +268,8 @@ install_for_test: _install
 	# Various directories are put on the -I paths by tools/Makefile;
 	# utils/ is one such, so we just dump the .cm* files in there for
 	# various things.
+	mkdir _runtest/external
+	cp $(main_build)/external/float32/*.{cma,a,cmxa} _runtest/external
 	mkdir _runtest/utils
 	cp _install/lib/ocaml/compiler-libs/*.{cmi,cmx} _runtest/utils
 	cp $(main_build)/$(ocamldir)/.ocamlcommon.objs/byte/*.cmo _runtest/utils

bytecomp/bytegen.ml

@@ -128,7 +128,8 @@ let preserve_tailcall_for_prim = function
   | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat _
-  | Pfloatofint (_, _) | Pnegfloat (_, _) | Pabsfloat (_, _)
+  | Pfloatofint (_, _) | Pfloatoffloat32 _ | Pfloat32offloat _
+  | Pnegfloat (_, _) | Pabsfloat (_, _)
   | Paddfloat (_, _) | Psubfloat (_, _) | Pmulfloat (_, _)
   | Pdivfloat (_, _) | Pfloatcomp (_, _) | Punboxed_float_comp (_, _)
   | Pstringlength | Pstringrefu  | Pstringrefs
@@ -495,6 +496,8 @@ let comp_primitive stack_info p sz args =
   | Poffsetref n -> Koffsetref n
   | Pintoffloat Pfloat64 -> Kccall("caml_int_of_float", 1)
   | Pfloatofint (Pfloat64, _) -> Kccall("caml_float_of_int", 1)
+  | Pfloatoffloat32 _ -> Kccall("caml_float_of_float32", 1)
+  | Pfloat32offloat _ -> Kccall("caml_float32_of_float", 1)
   | Pnegfloat (Pfloat64, _) -> Kccall("caml_neg_float", 1)
   | Pabsfloat (Pfloat64, _) -> Kccall("caml_abs_float", 1)
   | Paddfloat (Pfloat64, _) -> Kccall("caml_add_float", 2)

bytecomp/symtable.ml

@@ -148,9 +148,7 @@ 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 _) ->
-    (* CR mslater: (float32) use float32 in the compiler *)
-    assert false
+  | Const_base(Const_float32 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

@@ -183,6 +183,8 @@ type primitive =
   | Poffsetint of int
   | Poffsetref of int
   (* Float operations *)
+  | Pfloatoffloat32 of alloc_mode
+  | Pfloat32offloat of alloc_mode
   | Pintoffloat of boxed_float
   | Pfloatofint of boxed_float * alloc_mode
   | Pnegfloat of boxed_float * alloc_mode
@@ -1647,6 +1649,8 @@ let primitive_may_allocate : primitive -> alloc_mode option = function
   | Poffsetref _ -> None
   | Pintoffloat _ -> None
   | Pfloatofint (_, m) -> Some m
+  | Pfloatoffloat32 m -> Some m
+  | Pfloat32offloat m -> Some m
   | Pnegfloat (_, m) | Pabsfloat (_, m)
   | Paddfloat (_, m) | Psubfloat (_, m)
   | Pmulfloat (_, m) | Pdivfloat (_, m) -> Some m
@@ -1791,6 +1795,8 @@ let primitive_result_layout (p : primitive) =
   | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field)
   | Pmake_unboxed_product layouts -> layout_unboxed_product layouts
   | Pfloatfield _ -> layout_boxed_float Pfloat64
+  | Pfloatoffloat32 _ -> layout_boxed_float Pfloat64
+  | Pfloat32offloat _ -> layout_boxed_float Pfloat32
   | Pfloatofint (f, _) | Pnegfloat (f, _) | Pabsfloat (f, _)
   | Paddfloat (f, _) | Psubfloat (f, _) | Pmulfloat (f, _) | Pdivfloat (f, _)
   | Pbox_float (f, _) -> layout_boxed_float f
@@ -1861,7 +1867,7 @@ let primitive_result_layout (p : primitive) =
       begin match kind with
       | Pbigarray_unknown -> layout_any_value
       | Pbigarray_float32 ->
-        (* CR mslater: (float32) bigarrays *)
+        (* float32 bigarrays return 64-bit floats for backward compatibility. *)
         layout_boxed_float Pfloat64
       | Pbigarray_float64 -> layout_boxed_float Pfloat64
       | Pbigarray_sint8 | Pbigarray_uint8

lambda/lambda.mli

@@ -145,6 +145,9 @@ type primitive =
   | Poffsetint of int
   | Poffsetref of int
   (* Float operations *)
+  (* CR mslater: (float32) use a single cast primitive *)
+  | Pfloatoffloat32 of alloc_mode
+  | Pfloat32offloat of alloc_mode
   | Pintoffloat of boxed_float
   | Pfloatofint of boxed_float * alloc_mode
   | Pnegfloat of boxed_float * alloc_mode

lambda/printlambda.ml

@@ -535,6 +535,8 @@ let primitive ppf = function
   | Pcompare_bints bi -> fprintf ppf "compare_bints %s" (boxed_integer_name bi)
   | Poffsetint n -> fprintf ppf "%i+" n
   | Poffsetref n -> fprintf ppf "+:=%i"n
+  | Pfloatoffloat32 m -> print_boxed_float "float_of_float32" ppf Pfloat32 m
+  | Pfloat32offloat m -> print_boxed_float "float32_of_float" ppf Pfloat64 m
   | Pintoffloat bf -> fprintf ppf "int_of_%s" (boxed_float_name bf)
   | Pfloatofint (bf,m) ->
       fprintf ppf "%s_of_int%s" (boxed_float_name bf) (alloc_kind m)
@@ -822,6 +824,8 @@ let name_of_primitive = function
   | Pcompare_bints _ -> "Pcompare"
   | Poffsetint _ -> "Poffsetint"
   | Poffsetref _ -> "Poffsetref"
+  | Pfloatoffloat32 _ -> "Pfloatoffloat32"
+  | Pfloat32offloat _ -> "Pfloat32offloat"
   | Pintoffloat _ -> "Pintoffloat"
   | Pfloatofint (_, _) -> "Pfloatofint"
   | Pnegfloat (_, _) -> "Pnegfloat"

lambda/tmc.ml

@@ -889,6 +889,7 @@ let rec choice ctx t =
     | Pintcomp _ | Punboxed_int_comp _
     | Poffsetint _ | Poffsetref _
     | Pintoffloat _ | Pfloatofint (_, _)
+    | Pfloatoffloat32 _ | Pfloat32offloat _
     | Pnegfloat (_, _) | Pabsfloat (_, _)
     | Paddfloat (_, _) | Psubfloat (_, _)
     | Pmulfloat (_, _) | Pdivfloat (_, _)

lambda/transl_array_comprehension.ml

@@ -713,7 +713,7 @@ let initial_array ~loc ~array_kind ~array_size ~array_sizing =
     | Dynamic_size, Punboxedfloatarray Pfloat64 ->
       Mutable, Resizable_array.make ~loc array_kind (unboxed_float 0.)
     | (Fixed_size | Dynamic_size), Punboxedfloatarray Pfloat32 ->
-      (* CR mslater: (float32) array support *)
+      (* CR mslater: (float32) unboxed arrays *)
       assert false
     | Dynamic_size, Punboxedintarray Pint32 ->
       Mutable, Resizable_array.make ~loc array_kind (unboxed_int32 0l)
@@ -812,7 +812,7 @@ let body ~loc ~array_kind ~array_size ~array_sizing ~array ~index ~body =
     | Punboxedintarray _ ->
       set_element_in_bounds body
     | Punboxedfloatarray Pfloat32 ->
-      (* CR mslater: (float32) array support *)
+      (* CR mslater: (float32) unboxed arrays *)
       assert false
   in
   Lsequence

lambda/translprim.ml

@@ -267,7 +267,22 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
     | "%geint" -> Primitive ((Pintcomp Cge), 2)
     | "%incr" -> Primitive ((Poffsetref(1)), 1)
     | "%decr" -> Primitive ((Poffsetref(-1)), 1)
-    (* CR mslater: (float32) primitives *)
+    | "%floatoffloat32" -> Primitive (Pfloatoffloat32 mode, 1)
+    | "%float32offloat" -> Primitive (Pfloat32offloat mode, 1)
+    | "%intoffloat32" -> Primitive (Pintoffloat Pfloat32, 1)
+    | "%float32ofint" -> Primitive (Pfloatofint (Pfloat32, mode), 1)
+    | "%negfloat32" -> Primitive (Pnegfloat (Pfloat32, mode), 1)
+    | "%absfloat32" -> Primitive (Pabsfloat (Pfloat32, mode), 1)
+    | "%addfloat32" -> Primitive (Paddfloat (Pfloat32, mode), 2)
+    | "%subfloat32" -> Primitive (Psubfloat (Pfloat32, mode), 2)
+    | "%mulfloat32" -> Primitive (Pmulfloat (Pfloat32, mode), 2)
+    | "%divfloat32" -> Primitive (Pdivfloat (Pfloat32, mode), 2)
+    | "%eqfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFeq)), 2)
+    | "%noteqfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFneq)), 2)
+    | "%ltfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFlt)), 2)
+    | "%lefloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFle)), 2)
+    | "%gtfloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFgt)), 2)
+    | "%gefloat32" -> Primitive ((Pfloatcomp (Pfloat32, CFge)), 2)
     | "%intoffloat" -> Primitive (Pintoffloat Pfloat64, 1)
     | "%floatofint" -> Primitive (Pfloatofint (Pfloat64, mode), 1)
     | "%negfloat" -> Primitive (Pnegfloat (Pfloat64, mode), 1)
@@ -643,6 +658,7 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
       Primitive ((Pfloatarray_set_128 {unsafe = false}), 3)
     | "%caml_floatarray_set128u" ->
       Primitive ((Pfloatarray_set_128 {unsafe = true}), 3)
+    (* CR mslater: (float32) unboxed arrays *)
     | "%caml_unboxed_float_array_set128" ->
       Primitive ((Punboxed_float_array_set_128 {unsafe = false}), 3)
     | "%caml_unboxed_float_array_set128u" ->
@@ -684,6 +700,7 @@ 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)
     | "%get_header" -> Primitive (Pget_header mode, 1)
@@ -1407,6 +1424,8 @@ let lambda_primitive_needs_event_after = function
      collect the call stack. *)
   | Pduprecord _ | Pccall _
   | Pfloatofint (_, _)
+  | Pfloatoffloat32 _
+  | Pfloat32offloat _
   | Pnegfloat (_, _) | Pabsfloat (_, _)
   | Paddfloat (_, _) | Psubfloat (_, _)
   | Pmulfloat (_, _) | Pdivfloat (_, _)

middle_end/closure/closure.ml

@@ -1027,9 +1027,8 @@ 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 _x) ->
-          (* CR mslater: (float32) middle end support *)
-          assert false
+        | Const_base(Const_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 _) ->
             (* CR alanechang: implement unboxed constants in closure *)

middle_end/convert_primitives.ml

@@ -192,6 +192,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
   | Pbox_int (bi, m) -> Pbox_int (bi, m)
   | Pget_header m -> Pget_header m
   | Pdls_get -> Pdls_get
+  | Pfloat32offloat _
+  | Pfloatoffloat32 _
   | Pobj_magic _
   | Pbytes_to_string
   | Pbytes_of_string

middle_end/flambda/closure_conversion.ml

@@ -137,9 +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 _c) ->
-      (* CR mslater: (float32) middle end support *)
-      assert false
+  | Const_base (Const_float32 _) ->
+      Misc.fatal_error "float32 is not supported in closure. Consider using flambda2."
   | Const_base (Const_int32 c) ->
     register_const t (Allocated_const (Int32 c))
       Names.const_int32

middle_end/internal_variable_names.ml

@@ -125,6 +125,8 @@ let pfloatfield = "Pfloatfield"
 let pufloatfield = "Pufloatfield"
 let pmixedfield = "Pmixedfield"
 let pfloatofint = "Pfloatofint"
+let pfloat32offloat = "Pfloat32offloat"
+let pfloatoffloat32 = "Pfloatoffloat32"
 let pgetglobal = "Pgetglobal"
 let pgetpredef = "Pgetpredef"
 let pignore = "Pignore"
@@ -253,6 +255,8 @@ let pfloatfield_arg = "Pfloatfield_arg"
 let pufloatfield_arg = "Pufloatfield_arg"
 let pmixedfield_arg = "Pmixedfield_arg"
 let pfloatofint_arg = "Pfloatofint_arg"
+let pfloatoffloat32_arg = "Pfloatoffloat32_arg"
+let pfloat32offloat_arg = "Pfloat32offloat_arg"
 let pgetglobal_arg = "Pgetglobal_arg"
 let pgetpredef_arg = "Pgetpredef_arg"
 let pobj_dup_arg = "Pobj_dup_arg"
@@ -454,6 +458,8 @@ let of_primitive : Lambda.primitive -> string = function
   | Poffsetref _ -> poffsetref
   | Pintoffloat _ -> pintoffloat
   | Pfloatofint (_, _) -> pfloatofint
+  | Pfloatoffloat32 _ -> pfloatoffloat32
+  | Pfloat32offloat _ -> pfloat32offloat
   | Pnegfloat (_, _) -> pnegfloat
   | Pabsfloat (_, _) -> pabsfloat
   | Paddfloat (_, _) -> paddfloat
@@ -607,6 +613,8 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Poffsetref _ -> poffsetref_arg
   | Pintoffloat _ -> pintoffloat_arg
   | Pfloatofint (_, _) -> pfloatofint_arg
+  | Pfloatoffloat32 _ -> pfloatoffloat32_arg
+  | Pfloat32offloat _ -> pfloat32offloat_arg
   | Pnegfloat (_, _) -> pnegfloat_arg
   | Pabsfloat (_, _) -> pabsfloat_arg
   | Paddfloat (_, _) -> paddfloat_arg

typing/typedtree.mli

@@ -33,7 +33,7 @@ type constant =
   | Const_string of string * Location.t * string option
   | Const_float of string
   | Const_float32 of string
-  (* CR mslater: (float32) unboxed float32 *)
+  (* CR mslater: (float32) unboxed *)
   | Const_unboxed_float of string
   | Const_int32 of int32
   | Const_int64 of int64