diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml index b1536bbd013..e756537445f 100644 --- a/middle_end/clambda_primitives.ml +++ b/middle_end/clambda_primitives.ml @@ -210,4 +210,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 diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 13e502c8af8..f11784591ef 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/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 diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index d77812b871d..d2294664da2 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/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 diff --git a/ocaml/middle_end/clambda_primitives.ml b/ocaml/middle_end/clambda_primitives.ml index 2bd9360ea63..03cea8a9209 100644 --- a/ocaml/middle_end/clambda_primitives.ml +++ b/ocaml/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 diff --git a/ocaml/testsuite/tests/typing-layouts-float64/c_api.ml b/ocaml/testsuite/tests/typing-layouts-float64/c_api.ml index cebd559058d..6fbca60df05 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/c_api.ml +++ b/ocaml/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 diff --git a/ocaml/testsuite/tests/typing-layouts-float64/c_api.reference b/ocaml/testsuite/tests/typing-layouts-float64/c_api.reference index 49c8c81bcc9..fcbcf55a9de 100644 --- a/ocaml/testsuite/tests/typing-layouts-float64/c_api.reference +++ b/ocaml/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