flambda-backend: Fix bug in Clambda_primitives.result_layout. (#1833)

Author: ccasin

lambda/lambda.ml

@@ -1487,6 +1487,18 @@ let structured_constant_layout = function
   | Const_block _ | Const_immstring _ -> Pvalue Pgenval
   | Const_float_array _ | Const_float_block _ -> Pvalue (Parrayval Pfloatarray)
 
+let layout_of_native_repr : Primitive.native_repr -> _ = function
+  | Untagged_int ->  layout_int
+  | Unboxed_vector v -> layout_boxed_vector v
+  | Unboxed_float -> layout_boxed_float
+  | Unboxed_integer bi -> layout_boxedint bi
+  | Same_as_ocaml_repr s ->
+    begin match s with
+    | Value -> layout_any_value
+    | Float64 -> layout_unboxed_float
+    | Void -> assert false
+    end
+
 let primitive_result_layout (p : primitive) =
   match p with
   | Popaque layout | Pobj_magic layout -> layout
@@ -1504,17 +1516,7 @@ let primitive_result_layout (p : primitive) =
   | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _
   | Pbox_float _ -> layout_boxed_float
   | Punbox_float -> Punboxed_float
-  | Pccall { prim_native_repr_res = _, Untagged_int; _} -> layout_int
-  | Pccall { prim_native_repr_res = _, Unboxed_vector v; _} -> layout_boxed_vector v
-  | Pccall { prim_native_repr_res = _, Unboxed_float; _} -> layout_boxed_float
-  | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr s; _} ->
-      begin match s with
-      | Value -> layout_any_value
-      | Float64 -> layout_unboxed_float
-      | Void -> assert false
-      end
-  | Pccall { prim_native_repr_res = _, Unboxed_integer bi; _} ->
-      layout_boxedint bi
+  | Pccall { prim_native_repr_res = _, repr_res } -> layout_of_native_repr repr_res
   | Praise _ -> layout_bottom
   | Psequor | Psequand | Pnot
   | Pnegint | Paddint | Psubint | Pmulint

lambda/lambda.mli

@@ -309,6 +309,14 @@ val equal_boxed_vector_size : boxed_vector -> boxed_vector -> bool
 
 val must_be_value : layout -> value_kind
 
+(* This is the layout of ocaml values used as arguments to or returned from
+   primitives for this [native_repr].  So the legacy [Unboxed_float] - which is
+   a float that is unboxed before being passed to a C function - is mapped to
+   [layout_any_value], while [Same_as_ocaml_repr Float64] is mapped to
+   [layout_unboxed_float].
+*)
+val layout_of_native_repr : Primitive.native_repr -> layout
+
 type structured_constant =
     Const_base of constant
   | Const_block of int * structured_constant list

middle_end/clambda_primitives.ml

@@ -211,4 +211,6 @@ let result_layout (p : primitive) =
   match p with
   | Punbox_float -> Lambda.Punboxed_float
   | Punbox_int bi -> Lambda.Punboxed_int bi
+  | Pccall {prim_native_repr_res = (_, repr_res); _} ->
+    Lambda.layout_of_native_repr repr_res
   | _ -> Lambda.layout_any_value

testsuite/tests/typing-layouts-float64/c_api.ml

@@ -59,4 +59,9 @@ let sum_of_one_to_seven =
   in
   print_floatu "Function with many args, sum_of_one_to_seven" f
 
+(* Non-inlined eta expansion *)
+let[@inline never] sin_U_U' x = sin_U_U x
 
+let sin_seven =
+  let f = sin_U_U' (of_float 7.) in
+  print_floatu "Test U -> U eta expansion, sin seven" f

testsuite/tests/typing-layouts-float64/c_api.reference

@@ -4,3 +4,4 @@ Test U -> B, sin four: -0.76
 Test (B[@unboxed]) -> U, sin five: -0.96
 Test U -> (B[@unboxed]), sin six: -0.28
 Function with many args, sum_of_one_to_seven: 28.00
+Test U -> U eta expansion, sin seven: 0.66