diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 5c5f741e8f5..a69028ddefb 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -1930,7 +1930,8 @@ let box_sized size mode dbg exp = (* Simplification of some primitives into C calls *) -let default_prim name = Primitive.simple ~name ~arity:0 (*ignored*) ~alloc:true +let default_prim name = + Primitive.simple_on_values ~name ~arity:0 (*ignored*) ~alloc:true let int64_native_prim name arity ~alloc = let u64 = Primitive.(Prim_global, Unboxed_integer Pint64) in diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml index d6332849395..b7851224d48 100644 --- a/backend/cmmgen.ml +++ b/backend/cmmgen.ml @@ -612,7 +612,7 @@ let rec transl env e = transl_make_array dbg env kind alloc_heap args | (Pduparray _, [arg]) -> let prim_obj_dup = - Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true in transl_ccall env prim_obj_dup [arg] dbg | (Pmakearray _, []) -> @@ -895,9 +895,13 @@ and transl_make_array dbg env kind mode args = and transl_ccall env prim args dbg = let transl_arg native_repr arg = + (* CR layouts v2: This match to be extended with + | Same_as_ocaml_repr Float64 -> (XFloat, transl env arg) + in the PR that adds Float64 *) match native_repr with - | Same_as_ocaml_repr -> + | Same_as_ocaml_repr Value -> (XInt, transl env arg) + | Same_as_ocaml_repr Void -> assert false | Unboxed_float -> (XFloat, transl_unbox_float dbg env arg) | Unboxed_integer bi -> @@ -924,8 +928,12 @@ and transl_ccall env prim args dbg = (ty1 :: tys, arg' :: args') in let typ_res, wrap_result = + (* CR layouts v2: This match to be extended with + | Same_as_ocaml_repr Float64 -> (typ_float, fun x -> x) + in the PR that adds Float64 *) match prim.prim_native_repr_res with - | _, Same_as_ocaml_repr -> (typ_val, fun x -> x) + | _, Same_as_ocaml_repr Value -> (typ_val, fun x -> x) + | _, Same_as_ocaml_repr Void -> assert false (* TODO: Allow Alloc_local on suitably typed C stubs *) | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap) | _, Unboxed_integer Pint64 when size_int = 4 -> diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 7cc2e8a324c..43fab009bb4 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -152,8 +152,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = ~effects:Only_generative_effects ~coeffects:Has_coeffects ~native_name:"caml_obj_dup" - ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr] - ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr)) + ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr Layouts.Sort.Value] + ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr Layouts.Sort.Value)) | Punbox_float -> Punbox_float | Pbox_float m -> Pbox_float m | Punbox_int bi -> Punbox_int bi diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 7e25f986854..a2d6c2a23f2 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -79,7 +79,7 @@ let check_closure t ulam named : Clambda.ulambda = if not !Clflags.clambda_checks then ulam else let desc = - Primitive.simple ~name:"caml_check_value_is_closure" + Primitive.simple_on_values ~name:"caml_check_value_is_closure" ~arity:2 ~alloc:false in let str = Format.asprintf "%a" Flambda.print_named named in @@ -109,7 +109,7 @@ let check_field t ulam pos named_opt : Clambda.ulambda = if not !Clflags.clambda_checks then ulam else let desc = - Primitive.simple ~name:"caml_check_field_access" + Primitive.simple_on_values ~name:"caml_check_field_access" ~arity:3 ~alloc:false in let str = diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 05406b95229..728991b2ca3 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -439,7 +439,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds in let box_return_value = match prim_native_repr_res with - | _, Same_as_ocaml_repr -> None + | _, Same_as_ocaml_repr _ -> None | _, Unboxed_float -> Some (P.Box_number (Naked_float, Alloc_mode.For_allocations.heap)) | _, Unboxed_integer Pnativeint -> @@ -463,8 +463,11 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds in let kind_of_primitive_native_repr ((_, repr) : Primitive.mode * Primitive.native_repr) = + (* CR layouts v2: This match will be extended with [| Same_as_ocaml_repr + Float64 -> K.naked_float] in the PR that adds Float64. *) match repr with - | Same_as_ocaml_repr -> K.value + | Same_as_ocaml_repr Value -> K.value + | Same_as_ocaml_repr Void -> assert false | Unboxed_float -> K.naked_float | Unboxed_integer Pnativeint -> K.naked_nativeint | Unboxed_integer Pint32 -> K.naked_int32 @@ -549,7 +552,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds (arg_repr : Primitive.mode * Primitive.native_repr) -> let unbox_arg : P.unary_primitive option = match arg_repr with - | _, Same_as_ocaml_repr -> None + | _, Same_as_ocaml_repr _ -> None | _, Unboxed_float -> Some (P.Unbox_number Naked_float) | _, Unboxed_integer Pnativeint -> Some (P.Unbox_number Naked_nativeint) diff --git a/middle_end/flambda2/from_lambda/dissect_letrec.ml b/middle_end/flambda2/from_lambda/dissect_letrec.ml index 3f20f0e020d..551ac2e30f6 100644 --- a/middle_end/flambda2/from_lambda/dissect_letrec.ml +++ b/middle_end/flambda2/from_lambda/dissect_letrec.ml @@ -172,7 +172,7 @@ let lsequence (lam1, lam2) = [@@ocaml.warning "-fragile-match"] let caml_update_dummy_prim = - Primitive.simple ~name:"caml_update_dummy" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_update_dummy" ~arity:2 ~alloc:true let update_dummy var expr = Lprim (Pccall caml_update_dummy_prim, [Lvar var; expr], Loc_unknown) @@ -570,7 +570,7 @@ let dissect_letrec ~bindings ~body ~free_vars_kind = | Normal _tag -> "caml_alloc_dummy" | Boxed_float -> "caml_alloc_dummy_float" in - let desc = Primitive.simple ~name:fn ~arity:1 ~alloc:true in + let desc = Primitive.simple_on_values ~name:fn ~arity:1 ~alloc:true in let size : lambda = Lconst (Const_base (Const_int size)) in id, Lprim (Pccall desc, [size], Loc_unknown)) letrec.blocks diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 081b2c5292b..b495613bb54 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -678,7 +678,7 @@ let transform_primitive env (prim : L.primitive) args loc = then let arity = 1 + num_dimensions in let name = "caml_ba_get_" ^ string_of_int num_dimensions in - let desc = Primitive.simple ~name ~arity ~alloc:true in + let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in Primitive (L.Pccall desc, args, loc) else Misc.fatal_errorf @@ -695,7 +695,7 @@ let transform_primitive env (prim : L.primitive) args loc = then let arity = 2 + num_dimensions in let name = "caml_ba_set_" ^ string_of_int num_dimensions in - let desc = Primitive.simple ~name ~arity ~alloc:true in + let desc = Primitive.simple_on_values ~name ~arity ~alloc:true in Primitive (L.Pccall desc, args, loc) else Misc.fatal_errorf diff --git a/ocaml/.depend b/ocaml/.depend index 109dfb1b98b..62a55875f4f 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -434,7 +434,6 @@ parsing/jane_syntax.cmo : \ parsing/parsetree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ - utils/language_extension.cmi \ parsing/jane_syntax_parsing.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmi \ @@ -443,7 +442,6 @@ parsing/jane_syntax.cmx : \ parsing/parsetree.cmi \ parsing/longident.cmx \ parsing/location.cmx \ - utils/language_extension.cmx \ parsing/jane_syntax_parsing.cmx \ parsing/asttypes.cmi \ parsing/ast_helper.cmx \ @@ -1236,6 +1234,7 @@ typing/primitive.cmo : \ typing/outcometree.cmi \ utils/misc.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ parsing/attr_helper.cmi \ typing/primitive.cmi typing/primitive.cmx : \ @@ -1243,12 +1242,14 @@ typing/primitive.cmx : \ typing/outcometree.cmi \ utils/misc.cmx \ parsing/location.cmx \ + typing/layouts.cmx \ parsing/attr_helper.cmx \ typing/primitive.cmi typing/primitive.cmi : \ parsing/parsetree.cmi \ typing/outcometree.cmi \ - parsing/location.cmi + parsing/location.cmi \ + typing/layouts.cmi typing/printpat.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ @@ -1980,6 +1981,7 @@ typing/typeopt.cmi : \ typing/typedtree.cmi \ typing/path.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ typing/env.cmi typing/types.cmo : \ @@ -3710,6 +3712,7 @@ lambda/lambda.cmo : \ utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ typing/ident.cmi \ typing/env.cmi \ lambda/debuginfo.cmi \ @@ -3725,6 +3728,7 @@ lambda/lambda.cmx : \ utils/misc.cmx \ parsing/longident.cmx \ parsing/location.cmx \ + typing/layouts.cmx \ typing/ident.cmx \ typing/env.cmx \ lambda/debuginfo.cmx \ @@ -3739,6 +3743,7 @@ lambda/lambda.cmi : \ typing/primitive.cmi \ typing/path.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ typing/ident.cmi \ typing/env.cmi \ lambda/debuginfo.cmi \ @@ -3793,6 +3798,7 @@ lambda/matching.cmx : \ lambda/matching.cmi : \ typing/typedtree.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ lambda/debuginfo.cmi @@ -3881,6 +3887,7 @@ lambda/transl_array_comprehension.cmo : \ typing/predef.cmi \ utils/misc.cmi \ lambda/matching.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -3894,6 +3901,7 @@ lambda/transl_array_comprehension.cmx : \ typing/predef.cmx \ utils/misc.cmx \ lambda/matching.cmx \ + typing/layouts.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ @@ -3902,6 +3910,7 @@ lambda/transl_array_comprehension.cmx : \ lambda/transl_array_comprehension.cmi lambda/transl_array_comprehension.cmi : \ typing/typedtree.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ lambda/debuginfo.cmi lambda/transl_comprehension_utils.cmo : \ @@ -3923,6 +3932,7 @@ lambda/transl_list_comprehension.cmo : \ typing/typedtree.cmi \ lambda/transl_comprehension_utils.cmi \ lambda/matching.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ parsing/asttypes.cmi \ @@ -3932,12 +3942,14 @@ lambda/transl_list_comprehension.cmx : \ typing/typedtree.cmx \ lambda/transl_comprehension_utils.cmx \ lambda/matching.cmx \ + typing/layouts.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ parsing/asttypes.cmi \ lambda/transl_list_comprehension.cmi lambda/transl_list_comprehension.cmi : \ typing/typedtree.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ lambda/debuginfo.cmi lambda/translattribute.cmo : \ @@ -3980,6 +3992,7 @@ lambda/translclass.cmo : \ typing/path.cmi \ lambda/matching.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -3997,6 +4010,7 @@ lambda/translclass.cmx : \ typing/path.cmx \ lambda/matching.cmx \ parsing/location.cmx \ + typing/layouts.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ @@ -4083,6 +4097,7 @@ lambda/translcore.cmx : \ parsing/asttypes.cmi \ lambda/translcore.cmi lambda/translcore.cmi : \ + typing/types.cmi \ typing/typedtree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ @@ -4204,6 +4219,7 @@ lambda/translprim.cmo : \ utils/misc.cmi \ lambda/matching.cmi \ parsing/location.cmi \ + typing/layouts.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ @@ -4224,6 +4240,7 @@ lambda/translprim.cmx : \ utils/misc.cmx \ lambda/matching.cmx \ parsing/location.cmx \ + typing/layouts.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ diff --git a/ocaml/asmcomp/cmm_helpers.ml b/ocaml/asmcomp/cmm_helpers.ml index 87398c9785b..5f6edb8e368 100644 --- a/ocaml/asmcomp/cmm_helpers.ml +++ b/ocaml/asmcomp/cmm_helpers.ml @@ -1579,7 +1579,7 @@ let box_sized size mode dbg exp = (* Simplification of some primitives into C calls *) let default_prim name = - Primitive.simple ~name ~arity:0(*ignored*) ~alloc:true + Primitive.simple_on_values ~name ~arity:0(*ignored*) ~alloc:true let int64_native_prim name arity ~alloc = diff --git a/ocaml/asmcomp/cmmgen.ml b/ocaml/asmcomp/cmmgen.ml index 616d86a5152..cb576e08247 100644 --- a/ocaml/asmcomp/cmmgen.ml +++ b/ocaml/asmcomp/cmmgen.ml @@ -541,7 +541,7 @@ let rec transl env e = transl_make_array dbg env kind alloc_heap args | (Pduparray _, [arg]) -> let prim_obj_dup = - Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true in transl_ccall env prim_obj_dup [arg] dbg | (Pmakearray _, []) -> @@ -826,9 +826,13 @@ and transl_make_array dbg env kind mode args = and transl_ccall env prim args dbg = let transl_arg native_repr arg = + (* CR layouts v2: This match to be extended with + | Same_as_ocaml_repr Float64 -> (XFloat, transl env arg) + in the PR that adds Float64 *) match native_repr with - | Same_as_ocaml_repr -> + | Same_as_ocaml_repr Value -> (XInt, transl env arg) + | Same_as_ocaml_repr Void -> assert false | Unboxed_float -> (XFloat, transl_unbox_float dbg env arg) | Unboxed_integer bi -> @@ -856,7 +860,11 @@ and transl_ccall env prim args dbg = in let typ_res, wrap_result = match prim.prim_native_repr_res with - | _, Same_as_ocaml_repr -> (typ_val, fun x -> x) + (* CR layouts v2: This match to be extended with + | Same_as_ocaml_repr Float64 -> (typ_float, fun x -> x) + in the PR that adds Float64 *) + | _, Same_as_ocaml_repr Value -> (typ_val, fun x -> x) + | _, Same_as_ocaml_repr Void -> assert false (* TODO: Allow Alloc_local on suitably typed C stubs *) | _, Unboxed_float -> (typ_float, box_float dbg alloc_heap) | _, Unboxed_integer Pint64 when size_int = 4 -> diff --git a/ocaml/boot/ocamlc b/ocaml/boot/ocamlc index 99880e14bc4..b0ee3819b10 100755 Binary files a/ocaml/boot/ocamlc and b/ocaml/boot/ocamlc differ diff --git a/ocaml/boot/ocamllex b/ocaml/boot/ocamllex index b519679d2d4..6da593d2da4 100755 Binary files a/ocaml/boot/ocamllex and b/ocaml/boot/ocamllex differ diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index c3130582a5f..f3db45b26a3 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -797,7 +797,7 @@ let rec comp_expr env exp sz cont = comp_expr env (Lprim (Pmakearray (kind, mutability, m), args, loc)) sz cont | Lprim (Pduparray _, [arg], loc) -> let prim_obj_dup = - Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true + Primitive.simple_on_values ~name:"caml_obj_dup" ~arity:1 ~alloc:true in comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont | Lprim (Pduparray _, _, _) -> diff --git a/ocaml/compilerlibs/Makefile.compilerlibs b/ocaml/compilerlibs/Makefile.compilerlibs index cfe1310e253..2f33acedcce 100644 --- a/ocaml/compilerlibs/Makefile.compilerlibs +++ b/ocaml/compilerlibs/Makefile.compilerlibs @@ -80,9 +80,9 @@ PARSING_CMI = \ TYPING = \ typing/path.cmo \ + typing/layouts.cmo \ typing/primitive.cmo \ typing/shape.cmo \ - typing/layouts.cmo \ typing/types.cmo \ typing/btype.cmo \ typing/oprint.cmo \ diff --git a/ocaml/dune b/ocaml/dune index 2bc207bf353..0d412522832 100644 --- a/ocaml/dune +++ b/ocaml/dune @@ -68,7 +68,7 @@ asttypes parsetree ;; TYPING - ident path primitive shape layouts types btype oprint subst predef datarepr + ident path layouts primitive shape types btype oprint subst predef datarepr cmi_format persistent_env env errortrace typedtree printtyped ctype printtyp includeclass mtype envaux includecore tast_iterator tast_mapper signature_group cmt_format cms_format untypeast @@ -263,8 +263,8 @@ (parsetree.mli as compiler-libs/parsetree.mli) (ident.mli as compiler-libs/ident.mli) (path.mli as compiler-libs/path.mli) - (primitive.mli as compiler-libs/primitive.mli) (layouts.mli as compiler-libs/layouts.mli) + (primitive.mli as compiler-libs/primitive.mli) (types.mli as compiler-libs/types.mli) (btype.mli as compiler-libs/btype.mli) (binutils.mli as compiler-libs/binutils.mli) diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 7f3bca59f4a..48f210df8a7 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -637,13 +637,14 @@ let layout_class = Pvalue Pgenval let layout_module = Pvalue Pgenval let layout_module_field = Pvalue Pgenval let layout_functor = Pvalue Pgenval -let layout_float = Pvalue Pfloatval +let layout_boxed_float = Pvalue Pfloatval let layout_string = Pvalue Pgenval let layout_boxedint bi = Pvalue (Pboxedintval bi) let layout_lazy = Pvalue Pgenval let layout_lazy_contents = Pvalue Pgenval let layout_any_value = Pvalue Pgenval let layout_letrec = layout_any_value +let layout_probe_arg = Pvalue Pgenval (* CR ncourant: use [Ptop] or remove this as soon as possible. *) let layout_top = layout_any_value @@ -1438,12 +1439,15 @@ let primitive_result_layout (p : primitive) = | Pfield _ | Pfield_computed _ -> layout_field | Pfloatfield _ | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ - | Pbox_float _ -> layout_float + | Pbox_float _ -> layout_boxed_float | Punbox_float -> Punboxed_float | Pccall { prim_native_repr_res = _, Untagged_int; _} -> layout_int - | Pccall { prim_native_repr_res = _, Unboxed_float; _} -> layout_float - | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _} -> - layout_any_value + | 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 + | Void -> assert false + end | Pccall { prim_native_repr_res = _, Unboxed_integer bi; _} -> layout_boxedint bi | Praise _ -> layout_bottom @@ -1465,7 +1469,7 @@ let primitive_result_layout (p : primitive) = | Parrayrefu array_ref_kind | Parrayrefs array_ref_kind -> (match array_ref_kind with | Pintarray_ref -> layout_int - | Pfloatarray_ref _ -> layout_float + | Pfloatarray_ref _ -> layout_boxed_float | Pgenarray_ref _ | Paddrarray_ref -> layout_field) | Pbintofint (bi, _) | Pcvtbint (_,bi,_) | Pnegbint (bi, _) | Paddbint (bi, _) | Psubbint (bi, _) @@ -1482,7 +1486,7 @@ let primitive_result_layout (p : primitive) = | Pbigarrayref (_, _, kind, _) -> begin match kind with | Pbigarray_unknown -> layout_any_value - | Pbigarray_float32 | Pbigarray_float64 -> layout_float + | Pbigarray_float32 | Pbigarray_float64 -> layout_boxed_float | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 | Pbigarray_caml_int -> layout_int diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index cf4809d63fe..09ea1eb336d 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -527,7 +527,7 @@ val layout_module : layout val layout_functor : layout val layout_module_field : layout val layout_string : layout -val layout_float : layout +val layout_boxed_float : layout val layout_boxedint : boxed_integer -> layout (* A layout that is Pgenval because it is the field of a block *) val layout_field : layout @@ -537,6 +537,8 @@ val layout_lazy_contents : layout val layout_any_value : layout (* A layout that is Pgenval because it is bound by a letrec *) val layout_letrec : layout +(* The probe hack: Free vars in probes must have layout value. *) +val layout_probe_arg : layout val layout_top : layout val layout_bottom : layout diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index 273b9c26f65..e0f52b2a237 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -163,8 +163,8 @@ let expand_record_head h = { h with pat_desc = Record (Array.to_list lbl_all) } | _ -> h -let bind_alias p id ~arg ~action = - let k = Typeopt.layout p.pat_env p.pat_loc p.pat_type in +let bind_alias p id ~arg ~arg_sort ~action = + let k = Typeopt.layout p.pat_env p.pat_loc arg_sort p.pat_type in bind_with_layout Alias (id, k) arg action let head_loc ~scopes head = @@ -209,7 +209,8 @@ module Half_simple : sig type nonrec clause = pattern Non_empty_row.t clause - val of_clause : arg:lambda -> General.clause -> clause + val of_clause : + arg:lambda -> arg_sort:Layouts.sort -> General.clause -> clause end = struct include Patterns.Half_simple @@ -234,7 +235,7 @@ end = struct | _ -> p (* Explode or-patterns and turn aliases into bindings in actions *) - let of_clause ~arg cl = + let of_clause ~arg ~arg_sort cl = let rec aux (((p, patl), action) : General.clause) : clause = let continue p (view : General.view) : clause = aux (({ p with pat_desc = view }, patl), action) @@ -248,7 +249,7 @@ end = struct | `Alias (p, id, _, _) -> aux ( (General.view p, patl), - bind_alias p id ~arg ~action ) + bind_alias p id ~arg ~arg_sort ~action ) | `Record ([], _) as view -> stop p view | `Record (lbls, closed) -> let full_view = `Record (all_record_args lbls, closed) in @@ -277,6 +278,7 @@ module Simple : sig val explode_or_pat : arg:lambda -> + arg_sort:Layouts.sort -> Half_simple.pattern -> mk_action:(vars:Ident.t list -> lambda) -> patbound_action_vars:Ident.t list -> @@ -331,7 +333,7 @@ end = struct compiling in [do_for_multiple_match] where it is a tuple of variables. *) - let explode_or_pat ~arg (p : Half_simple.pattern) + let explode_or_pat ~arg ~arg_sort (p : Half_simple.pattern) ~mk_action ~patbound_action_vars : (pattern * lambda) list = let rec explode p aliases rem = @@ -384,7 +386,7 @@ end = struct let pat, action = fresh_clause (Some id) action_vars renaming_env rem_vars in - pat, bind_alias pat id ~arg ~action + pat, bind_alias pat id ~arg ~arg_sort ~action end in fresh_clause None [] [] patbound_action_vars :: rem @@ -939,7 +941,7 @@ end type 'row pattern_matching = { mutable cases : 'row list; - args : (lambda * let_kind * layout) list; + args : (lambda * let_kind * Layouts.sort * layout) list; (** args are not just Ident.t in at least the following cases: - when matching the arguments of a constructor, direct field projections are used (make_field_args) @@ -1113,16 +1115,16 @@ let safe_before ((p, ps), act_p) l = || not (may_compats (General.erase p :: ps) (General.erase q :: qs))) l -let half_simplify_nonempty ~arg (cls : Typedtree.pattern Non_empty_row.t clause) - : Half_simple.clause = +let half_simplify_nonempty ~arg ~arg_sort + (cls : Typedtree.pattern Non_empty_row.t clause) : Half_simple.clause = cls |> map_on_row (Non_empty_row.map_first General.view) - |> Half_simple.of_clause ~arg + |> Half_simple.of_clause ~arg ~arg_sort -let half_simplify_clause ~arg (cls : Typedtree.pattern list clause) = +let half_simplify_clause ~arg ~arg_sort (cls : Typedtree.pattern list clause) = cls |> map_on_row Non_empty_row.of_initial - |> half_simplify_nonempty ~arg + |> half_simplify_nonempty ~arg ~arg_sort (* Once matchings are *fully* simplified, one can easily find their nature. *) @@ -1338,7 +1340,7 @@ let as_matrix cases = *) -let rec split_or ~arg (cls : Half_simple.clause list) args def = +let rec split_or ~arg ~arg_sort (cls : Half_simple.clause list) args def = let rec do_split (rev_before : Simple.clause list) rev_ors rev_no = function | [] -> cons_next (List.rev rev_before) (List.rev rev_ors) (List.rev rev_no) @@ -1369,7 +1371,7 @@ let rec split_or ~arg (cls : Half_simple.clause list) args def = in match yesor with | [] -> split_no_or yes args def nexts - | _ -> precompile_or ~arg yes yesor args def nexts + | _ -> precompile_or ~arg ~arg_sort yes yesor args def nexts in do_split [] [] [] cls @@ -1446,7 +1448,7 @@ and precompile_var args cls def k = If the rest doesn't generate any split, abort and do_not_precompile. *) match args with | [] -> assert false - | _ :: ((Lvar v, _, _) as arg) :: rargs -> ( + | _ :: ((Lvar v, _, arg_sort, _) as arg) :: rargs -> ( (* We will use the name of the head column of the submatrix we compile, and this is the *second* column of our argument. *) match cls with @@ -1464,11 +1466,11 @@ and precompile_var args cls def k = (* we learned by pattern-matching on [args] that [p::ps] has at least two arguments, so [ps] must be non-empty *) - half_simplify_clause ~arg:(Lvar v) (ps, act)) + half_simplify_clause ~arg:(Lvar v) ~arg_sort (ps, act)) cls and var_def = Default_environment.pop_column def in let { me = first; matrix }, nexts = - split_or ~arg:(Lvar v) var_cls var_args var_def + split_or ~arg:(Lvar v) ~arg_sort var_cls var_args var_def in (* Compute top information *) match nexts with @@ -1519,7 +1521,7 @@ and do_not_precompile args cls def k = }, k ) -and precompile_or ~arg (cls : Simple.clause list) ors args def k = +and precompile_or ~arg ~arg_sort (cls : Simple.clause list) ors args def k = (* Example: if [cls] is a single-row matrix s11 p12 .. p1n -> act1 @@ -1586,10 +1588,10 @@ and precompile_or ~arg (cls : Simple.clause list) ors args def k = let patbound_action_vars = (* variables bound in the or-pattern that are used in the orpm actions *) - Typedtree.pat_bound_idents_with_types orp - |> List.filter (fun (id, _) -> Ident.Set.mem id pm_fv) - |> List.map (fun (id, ty) -> - (id, Typeopt.layout orp.pat_env orp.pat_loc ty)) + Typedtree.pat_bound_idents_full arg_sort orp + |> List.filter (fun (id, _, _, _) -> Ident.Set.mem id pm_fv) + |> List.map (fun (id, _, ty, id_sort) -> + (id, Typeopt.layout orp.pat_env orp.pat_loc id_sort ty)) in let or_num = next_raise_count () in let new_patl = Patterns.omega_list patl in @@ -1597,7 +1599,7 @@ and precompile_or ~arg (cls : Simple.clause list) ors args def k = Lstaticraise (or_num, List.map (fun v -> Lvar v) vars) in let new_cases = - Simple.explode_or_pat ~arg p + Simple.explode_or_pat ~arg ~arg_sort p ~mk_action:mk_new_action ~patbound_action_vars:(List.map fst patbound_action_vars) |> List.map (fun (p, act) -> ((p, new_patl), act)) in @@ -1645,8 +1647,10 @@ let split_and_precompile_simplified pm = dbg_split_and_precompile pm next nexts; (next, nexts) -let split_and_precompile_half_simplified ~arg pm = - let { me = next }, nexts = split_or ~arg pm.cases pm.args pm.default in +let split_and_precompile_half_simplified ~arg ~arg_sort pm = + let { me = next }, nexts = + split_or ~arg ~arg_sort pm.cases pm.args pm.default + in dbg_split_and_precompile pm next nexts; (next, nexts) @@ -1677,7 +1681,7 @@ let make_line_matching get_expr_args head def = function } type 'a division = { - args : (lambda * let_kind * layout) list; + args : (lambda * let_kind * Layouts.sort * layout) list; cells : ('a * cell) list } @@ -1773,7 +1777,7 @@ let get_pat_args_constr p rem = args @ rem | _ -> assert false -let get_expr_args_constr ~scopes head (arg, _mut, layout) rem = +let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem = let cstr = match head.pat_desc with | Patterns.Head.Construct cstr -> cstr @@ -1790,18 +1794,18 @@ let get_expr_args_constr ~scopes head (arg, _mut, layout) rem = argl else (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), binding_kind, - layout_field) + Sort.for_constructor_arg, layout_field) :: make_args (pos + 1) in make_args first_pos in if cstr.cstr_inlined <> None then - (arg, Alias, layout) :: rem + (arg, Alias, sort, layout) :: rem else match cstr.cstr_repr with | Variant_boxed _ -> make_field_accesses Alias 0 (cstr.cstr_arity - 1) rem - | Variant_unboxed -> (arg, Alias, layout) :: rem + | Variant_unboxed -> (arg, Alias, sort, layout) :: rem | Variant_extensible -> make_field_accesses Alias 1 cstr.cstr_arity rem let divide_constructor ~scopes ctx pm = @@ -1819,10 +1823,13 @@ let get_expr_args_variant_constant = drop_expr_arg let nonconstant_variant_field index = Lambda.Pfield(index, Reads_agree) -let get_expr_args_variant_nonconst ~scopes head (arg, _mut, _layout) rem = +let get_expr_args_variant_nonconst ~scopes head (arg, _mut, _sort, _layout) + rem = let loc = head_loc ~scopes head in let field_prim = nonconstant_variant_field 1 in - (Lprim (field_prim, [ arg ], loc), Alias, layout_field) :: rem + (Lprim (field_prim, [ arg ], loc), Alias, Sort.for_constructor_arg, + layout_field) + :: rem let divide_variant ~scopes row ctx { cases = cl; args; default = def } = let rec divide = function @@ -1884,7 +1891,8 @@ let get_pat_args_lazy p rem = No other call than Obj.tag when the value has been forced before. *) -let prim_obj_tag = Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false +let prim_obj_tag = + Primitive.simple_on_values ~name:"caml_obj_tag" ~arity:1 ~alloc:false let get_mod_field modname field = lazy @@ -2029,9 +2037,10 @@ let inline_lazy_force arg pos loc = tables (~ 250 elts); conditionals are better *) inline_lazy_force_cond arg pos loc -let get_expr_args_lazy ~scopes head (arg, _mut, _layout) rem = +let get_expr_args_lazy ~scopes head (arg, _mut, _sort, _layout) rem = let loc = head_loc ~scopes head in - (inline_lazy_force arg Rc_normal loc, Strict, layout_lazy_contents) :: rem + (inline_lazy_force arg Rc_normal loc, Strict, Sort.for_lazy_body, + layout_lazy_contents) :: rem let divide_lazy ~scopes head ctx pm = divide_line (Context.specialize head) @@ -2047,14 +2056,15 @@ let get_pat_args_tuple arity p rem = | { pat_desc = Tpat_tuple args } -> args @ rem | _ -> assert false -let get_expr_args_tuple ~scopes head (arg, _mut, _layout) rem = +let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem = let loc = head_loc ~scopes head in let arity = Patterns.Head.arity head in let rec make_args pos = if pos >= arity then rem else - (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), Alias, layout_field) + (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), Alias, + Sort.for_tuple_element, layout_field) :: make_args (pos + 1) in make_args 0 @@ -2085,7 +2095,7 @@ let get_pat_args_record num_fields p rem = record_matching_line num_fields lbl_pat_list @ rem | _ -> assert false -let get_expr_args_record ~scopes head (arg, _mut, layout) rem = +let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem = let loc = head_loc ~scopes head in let all_labels = let open Patterns.Head in @@ -2106,34 +2116,36 @@ let get_expr_args_record ~scopes head (arg, _mut, layout) rem = | Immutable -> Reads_agree | Mutable -> Reads_vary in - let access, layout = - (* CR layouts v2: Here we'll need to get the layout from the + let access, sort, layout = + (* CR layouts v5: Here we'll need to get the layout from the record_representation and translate it to `Lambda.layout`, rather than just using layout_field everywhere. (Though layout_field is safe for now, particularly after checking for void above.) I think only the sort information matters here, so when we make that change - we'll probably want a cheaper version of the `Typeopt.layout` - function that avoids calling `value_kind` in the value case. *) + we may want to use `Typeopt.layout_of_sort` rather than + `Typeopt.layout`. *) match lbl.lbl_repres with | Record_boxed _ | Record_inlined (_, Variant_boxed _) -> - Lprim (Pfield (lbl.lbl_pos, sem), [ arg ], loc), layout_field + Lprim (Pfield (lbl.lbl_pos, sem), [ arg ], loc), + Sort.for_record_field, layout_field | Record_unboxed - | Record_inlined (_, Variant_unboxed) -> arg, layout + | Record_inlined (_, Variant_unboxed) -> arg, sort, layout | Record_float -> (* TODO: could optimise to Alloc_local sometimes *) Lprim (Pfloatfield (lbl.lbl_pos, sem, alloc_heap), [ arg ], loc), - (* CR layouts v2: is this really unboxed float? *) - layout_float + (* Here we are projecting a boxed float from a float record. *) + Sort.for_predef_value, layout_boxed_float | Record_inlined (_, Variant_extensible) -> - Lprim (Pfield (lbl.lbl_pos + 1, sem), [ arg ], loc), layout_field + Lprim (Pfield (lbl.lbl_pos + 1, sem), [ arg ], loc), + Sort.for_record_field, layout_field in let str = match lbl.lbl_mut with | Immutable -> Alias | Mutable -> StrictOpt in - (access, str, layout) :: make_args (pos + 1) + (access, str, sort, layout) :: make_args (pos + 1) in make_args 0 @@ -2160,7 +2172,7 @@ let get_pat_args_array p rem = | { pat_desc = Tpat_array (_, patl) } -> patl @ rem | _ -> assert false -let get_expr_args_array ~scopes kind head (arg, _mut, _layout) rem = +let get_expr_args_array ~scopes kind head (arg, _mut, _sort, _layout) rem = let am, len = let open Patterns.Head in match head.pat_desc with @@ -2182,6 +2194,7 @@ let get_expr_args_array ~scopes kind head (arg, _mut, _layout) rem = (match am with | Mutable -> StrictOpt | Immutable -> Alias), + Sort.for_array_get_result, layout_field) :: make_args (pos + 1) in @@ -2211,10 +2224,12 @@ let divide_array ~scopes kind ctx pm = let strings_test_threshold = 8 let prim_string_notequal = - Pccall (Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false) + Pccall (Primitive.simple_on_values ~name:"caml_string_notequal" ~arity:2 + ~alloc:false) let prim_string_compare = - Pccall (Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false) + Pccall (Primitive.simple_on_values ~name:"caml_string_compare" ~arity:2 + ~alloc:false) let bind_sw arg layout k = match arg with @@ -3329,13 +3344,17 @@ and compile_match_nonempty ~scopes value_kind repr partial ctx (m : Typedtree.pattern Non_empty_row.t clause pattern_matching)= match m with | { cases = []; args = [] } -> comp_exit ctx m - | { args = (arg, str, layout) :: argl } -> + | { args = (arg, str, arg_sort, layout) :: argl } -> let v, newarg = arg_to_var arg m.cases in - let args = (newarg, Alias, layout) :: argl in - let cases = List.map (half_simplify_nonempty ~arg:newarg) m.cases in + let args = (newarg, Alias, arg_sort, layout) :: argl in + let cases = + List.map (half_simplify_nonempty ~arg:newarg ~arg_sort) + m.cases + in let m = { m with args; cases } in let first_match, rem = - split_and_precompile_half_simplified ~arg:newarg m in + split_and_precompile_half_simplified ~arg:newarg ~arg_sort m + in combine_handlers ~scopes value_kind repr partial ctx (v, str, layout, arg) first_match rem | _ -> assert false @@ -3343,8 +3362,8 @@ and compile_match_simplified ~scopes value_kind repr partial ctx (m : Simple.clause pattern_matching) = match m with | { cases = []; args = [] } -> comp_exit ctx m - | { args = ((Lvar v as arg), str, layout) :: argl } -> - let args = (arg, Alias, layout) :: argl in + | { args = ((Lvar v as arg), str, sort, layout) :: argl } -> + let args = (arg, Alias, sort, layout) :: argl in let m = { m with args } in let first_match, rem = split_and_precompile_simplified m in combine_handlers value_kind ~scopes repr partial ctx (v, str, layout, arg) @@ -3385,7 +3404,7 @@ and do_compile_matching ~scopes value_kind repr partial ctx pmh = | Pm pm -> ( let arg = match pm.args with - | (first_arg, _, _) :: _ -> first_arg + | (first_arg, _, _, _) :: _ -> first_arg | _ -> (* We arrive in do_compile_matching from: - compile_matching @@ -3589,7 +3608,7 @@ let check_total ~scopes value_kind loc ~failer total lambda i = Lstaticcatch (lambda, (i, []), failure_handler ~scopes loc ~failer (), value_kind) -let toplevel_handler ~scopes value_kind loc ~failer partial args cases compile_fun = +let toplevel_handler ~scopes ~return_layout loc ~failer partial args cases compile_fun = match partial with | Total -> let default = Default_environment.empty in @@ -3606,22 +3625,25 @@ let toplevel_handler ~scopes value_kind loc ~failer partial args cases compile_f begin match compile_fun Partial pm with | exception Unused -> assert false | (lam, total) -> - check_total ~scopes value_kind loc ~failer total lam raise_num + check_total ~scopes return_layout loc ~failer total lam raise_num end -let compile_matching ~scopes value_kind loc ~failer repr (arg, arg_layout) pat_act_list partial = +let compile_matching ~scopes ~arg_sort ~arg_layout ~return_layout loc ~failer repr arg + pat_act_list partial = let partial = check_partial pat_act_list partial in - let args = [ (arg, Strict, arg_layout) ] in + let args = [ (arg, Strict, arg_sort, arg_layout) ] in let rows = map_on_rows (fun pat -> (pat, [])) pat_act_list in - toplevel_handler ~scopes value_kind loc ~failer partial args rows (fun partial pm -> - compile_match_nonempty ~scopes value_kind repr partial (Context.start 1) pm) + toplevel_handler ~scopes ~return_layout loc ~failer partial args rows + (fun partial pm -> compile_match_nonempty ~scopes return_layout repr + partial (Context.start 1) pm) -let for_function ~scopes kind loc repr param pat_act_list partial = - compile_matching ~scopes kind loc ~failer:Raise_match_failure - repr param pat_act_list partial +let for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc repr param + pat_act_list partial = + compile_matching ~scopes ~arg_sort ~arg_layout ~return_layout loc + ~failer:Raise_match_failure repr param pat_act_list partial (* In the following two cases, exhaustiveness info is not available! *) -let for_trywith ~scopes value_kind loc param pat_act_list = +let for_trywith ~scopes ~return_layout loc param pat_act_list = (* Note: the failure action of [for_trywith] corresponds to an exception that is not matched by a try..with handler, and is thus reraised for the next handler in the stack. @@ -3629,13 +3651,16 @@ let for_trywith ~scopes value_kind loc param pat_act_list = It is important to *not* include location information in the reraise (hence the [_noloc]) to avoid seeing this silent reraise in exception backtraces. *) - compile_matching ~scopes value_kind loc ~failer:(Reraise_noloc param) - None (param, layout_block) pat_act_list Partial + compile_matching ~scopes ~arg_sort:Sort.for_predef_value + ~arg_layout:layout_block ~return_layout loc ~failer:(Reraise_noloc param) + None param pat_act_list Partial -let simple_for_let ~scopes value_kind loc param pat body = - compile_matching ~scopes value_kind loc ~failer:Raise_match_failure - None (param, Typeopt.layout pat.pat_env pat.pat_loc pat.pat_type) - [ (pat, body) ] Partial +let simple_for_let ~scopes ~arg_sort ~return_layout loc param pat body = + let arg_layout = + Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type + in + compile_matching ~scopes ~arg_sort ~arg_layout ~return_layout loc + ~failer:Raise_match_failure None param [ (pat, body) ] Partial (* Optimize binding of immediate tuples @@ -3736,42 +3761,46 @@ let rec map_return f = function can be costly (one unnecessary tuple allocation). *) -let assign_pat ~scopes value_kind opt nraise catch_ids loc pat lam = - let rec collect acc pat lam = +let assign_pat ~scopes body_layout opt nraise catch_ids loc pat pat_sort lam = + let rec collect pat_sort acc pat lam = match (pat.pat_desc, lam) with | Tpat_tuple patl, Lprim (Pmakeblock _, lams, _) -> opt := true; - List.fold_left2 collect acc patl lams + List.fold_left2 (collect Sort.for_tuple_element) acc patl lams | Tpat_tuple patl, Lconst (Const_block (_, scl)) -> opt := true; - let collect_const acc pat sc = collect acc pat (Lconst sc) in + let collect_const acc pat sc = + collect Sort.for_tuple_element acc pat (Lconst sc) + in List.fold_left2 collect_const acc patl scl | _ -> (* pattern idents will be bound in staticcatch (let body), so we refresh them here to guarantee binders uniqueness *) let pat_ids = pat_bound_idents pat in let fresh_ids = List.map (fun id -> (id, Ident.rename id)) pat_ids in - (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc + (fresh_ids, alpha_pat fresh_ids pat, lam, pat_sort) :: acc in (* sublets were accumulated by 'collect' with the leftmost tuple pattern at the bottom of the list; to respect right-to-left evaluation order for tuples, we must evaluate sublets top-to-bottom. To preserve tail-rec, we will fold_left the reversed list. *) - let rev_sublets = List.rev (collect [] pat lam) in + let rev_sublets = List.rev (collect pat_sort [] pat lam) in let exit = (* build an Ident.tbl to avoid quadratic refreshing costs *) let add t (id, fresh_id) = Ident.add id fresh_id t in - let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in + let add_ids acc (ids, _pat, _lam, _sort) = List.fold_left add acc ids in let tbl = List.fold_left add_ids Ident.empty rev_sublets in let fresh_var id = Lvar (Ident.find_same id tbl) in Lstaticraise (nraise, List.map fresh_var catch_ids) in - let push_sublet code (_ids, pat, lam) = - simple_for_let ~scopes value_kind loc lam pat code in + let push_sublet code (_ids, pat, lam, pat_sort ) = + simple_for_let ~scopes ~arg_sort:pat_sort ~return_layout:body_layout loc lam + pat code + in List.fold_left push_sublet exit rev_sublets -let for_let ~scopes loc param pat body_kind body = +let for_let ~scopes ~arg_sort ~return_layout loc param pat body = match pat.pat_desc with | Tpat_any -> (* This eliminates a useless variable (and stack slot in bytecode) @@ -3779,7 +3808,7 @@ let for_let ~scopes loc param pat body_kind body = Lsequence (param, body) | Tpat_var (id, _, _) -> (* fast path, and keep track of simple bindings to unboxable numbers *) - let k = Typeopt.layout pat.pat_env pat.pat_loc pat.pat_type in + let k = Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in Llet (Strict, k, id, param, body) | _ -> let opt = ref false in @@ -3787,29 +3816,36 @@ let for_let ~scopes loc param pat body_kind body = let catch_ids = pat_bound_idents_with_types pat in let ids_with_kinds = List.map - (fun (id, typ) -> (id, Typeopt.layout pat.pat_env pat.pat_loc typ)) + (fun (id, typ) -> + (id, Typeopt.layout pat.pat_env pat.pat_loc arg_sort typ)) catch_ids in let ids = List.map (fun (id, _) -> id) catch_ids in let bind = - map_return (assign_pat ~scopes body_kind opt nraise ids loc pat) param in + map_return (assign_pat ~scopes return_layout opt nraise ids loc pat + arg_sort) + param + in if !opt then - Lstaticcatch (bind, (nraise, ids_with_kinds), body, body_kind) + Lstaticcatch (bind, (nraise, ids_with_kinds), body, return_layout) else - simple_for_let ~scopes body_kind loc param pat body + simple_for_let ~scopes ~arg_sort ~return_layout loc param pat body (* Handling of tupled functions and matchings *) (* Easy case since variables are available *) -let for_tupled_function ~scopes loc kind paraml pats_act_list partial = +let for_tupled_function ~scopes ~return_layout loc paraml pats_act_list partial = let partial = check_partial_list pats_act_list partial in (* The arguments of a tupled function are always values since they must be fields *) - let args = List.map (fun id -> (Lvar id, Strict, layout_field)) paraml in + let args = + List.map (fun id -> (Lvar id, Strict, Sort.for_tuple_element, layout_field)) + paraml + in let handler = - toplevel_handler ~scopes kind loc ~failer:Raise_match_failure + toplevel_handler ~scopes ~return_layout loc ~failer:Raise_match_failure partial args pats_act_list in handler (fun partial pm -> - compile_match ~scopes kind None partial + compile_match ~scopes return_layout None partial (Context.start (List.length paraml)) pm ) @@ -3891,58 +3927,75 @@ let compile_flattened ~scopes value_kind repr partial ctx pmh = (compile_match ~scopes value_kind repr partial) lam total ctx hs -let do_for_multiple_match ~scopes value_kind loc paraml mode pat_act_list partial = +let do_for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list partial = + (* CR layouts v5: This function is called in cases where the scrutinee of a + match is a literal tuple (e.g., [match e1, e2, e3 with ...]). The + typechecker treats the scrutinee here like any other tuple, so it's fine to + assume the whole thing and the elements have sort value. That will change + when we allow non-values in structures. *) let repr = None in + let param_lambda = List.map (fun (l, _, _) -> l) paraml in let arg = let sloc = Scoped_location.of_location ~scopes loc in - (* CR ncourant: this can build a mixed block, but it should never actually be - created except if the pattern-matching binds it, in which case it should be - rejected by the typing. Do we really trust this case will not happen? *) - Lprim (Pmakeblock (0, Immutable, None, mode), List.map fst paraml, sloc) in + Lprim (Pmakeblock (0, Immutable, None, mode), param_lambda, sloc) + in + let arg_sort = Sort.for_tuple in let handler = let partial = check_partial pat_act_list partial in let rows = map_on_rows (fun p -> (p, [])) pat_act_list in - toplevel_handler ~scopes value_kind loc ~failer:Raise_match_failure - partial [ (arg, Strict, layout_block) ] rows in + toplevel_handler ~scopes ~return_layout loc ~failer:Raise_match_failure + partial [ (arg, Strict, Sort.for_tuple, layout_block) ] rows in handler (fun partial pm1 -> let pm1_half = - { pm1 with cases = List.map (half_simplify_nonempty ~arg) pm1.cases } + { pm1 with + cases = List.map (half_simplify_nonempty ~arg ~arg_sort) pm1.cases } + in + let next, nexts = split_and_precompile_half_simplified ~arg ~arg_sort pm1_half in + let size = List.length paraml in + let (idl_with_layouts, args) = + List.map (function + | Lvar id as lid, sort, layout -> + (id, layout), (lid, Alias, sort, layout) + | _, sort, layout -> + let id = Ident.create_local "*match*" in + (id, layout), (Lvar id, Alias, sort, layout)) + paraml + |> List.split in - let next, nexts = split_and_precompile_half_simplified ~arg pm1_half in - let size = List.length paraml - and idl_with_layouts = List.map (function - | Lvar id, layout -> id, layout - | _, layout -> Ident.create_local "*match*", layout) paraml in - let args = List.map (fun (id, layout) -> (Lvar id, Alias, layout)) idl_with_layouts in let flat_next = flatten_precompiled size args next and flat_nexts = List.map (fun (e, pm) -> (e, flatten_precompiled size args pm)) nexts in let lam, total = - comp_match_handlers value_kind (compile_flattened ~scopes value_kind repr) partial + comp_match_handlers return_layout + (compile_flattened ~scopes return_layout repr) partial (Context.start size) flat_next flat_nexts in - List.fold_right2 (bind_with_layout Strict) idl_with_layouts (List.map fst paraml) lam, total + List.fold_right2 (bind_with_layout Strict) idl_with_layouts param_lambda lam, + total ) (* PR#4828: Believe it or not, the 'paraml' argument below may not be side effect free. *) -let param_to_var (param, layout) = +let param_to_var (param, sort, layout) = match param with - | Lvar v -> (v, layout, None) - | _ -> (Ident.create_local "*match*", layout, Some param) + | Lvar v -> (v, sort, layout, None) + | _ -> (Ident.create_local "*match*", sort, layout, Some param) -let bind_opt (v, layout, eo) k = +let bind_opt (v, _, layout, eo) k = match eo with | None -> k | Some e -> Lambda.bind_with_layout Strict (v, layout) e k -let for_multiple_match ~scopes value_kind loc paraml mode pat_act_list partial = +let for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list partial = let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v, layout, _) -> (Lvar v, layout)) v_paraml in + let paraml = + List.map (fun (v, sort, layout, _) -> (Lvar v, sort, layout)) v_paraml + in List.fold_right bind_opt v_paraml - (do_for_multiple_match ~scopes value_kind loc paraml mode pat_act_list partial) + (do_for_multiple_match ~scopes ~return_layout loc paraml mode pat_act_list + partial) (* Error report *) (* CR layouts v2: This file didn't use to have the report_error infrastructure - diff --git a/ocaml/lambda/matching.mli b/ocaml/lambda/matching.mli index 9753213061c..904c49c22a0 100644 --- a/ocaml/lambda/matching.mli +++ b/ocaml/lambda/matching.mli @@ -21,24 +21,27 @@ open Debuginfo.Scoped_location (* Entry points to match compiler *) val for_function: - scopes:scopes -> layout -> Location.t -> - int ref option -> (lambda * layout) -> (pattern * lambda) list -> partial -> + scopes:scopes -> + arg_sort:Layouts.sort -> arg_layout:layout -> return_layout:layout -> + Location.t -> int ref option -> lambda -> (pattern * lambda) list -> + partial -> lambda val for_trywith: - scopes:scopes -> layout -> Location.t -> + scopes:scopes -> return_layout:layout -> Location.t -> lambda -> (pattern * lambda) list -> lambda val for_let: - scopes:scopes -> Location.t -> - lambda -> pattern -> layout -> lambda -> + scopes:scopes -> arg_sort:Layouts.sort -> return_layout:layout -> + Location.t -> lambda -> pattern -> lambda -> lambda val for_multiple_match: - scopes:scopes -> layout -> Location.t -> - (lambda * layout) list -> alloc_mode -> (pattern * lambda) list -> partial -> + scopes:scopes -> return_layout:layout -> Location.t -> + (lambda * Layouts.sort * layout) list -> alloc_mode -> + (pattern * lambda) list -> partial -> lambda val for_tupled_function: - scopes:scopes -> Location.t -> layout -> + scopes:scopes -> return_layout:layout -> Location.t -> Ident.t list -> (pattern list * lambda) list -> partial -> lambda diff --git a/ocaml/lambda/transl_array_comprehension.ml b/ocaml/lambda/transl_array_comprehension.ml index 4277e8e4a46..bd92585eca4 100644 --- a/ocaml/lambda/transl_array_comprehension.ml +++ b/ocaml/lambda/transl_array_comprehension.ml @@ -1,3 +1,4 @@ +open Layouts open Lambda open Typedtree open Asttypes @@ -455,7 +456,7 @@ let iterator ~transl_exp ~scopes ~loc | Texp_comp_range { ident; pattern = _; start; stop; direction } -> let bound name value = Let_binding.make (Immutable Strict) (Pvalue Pintval) - name (transl_exp ~scopes value) + name (transl_exp ~scopes Sort.for_predef_value value) in let start = bound "start" start in let stop = bound "stop" stop in @@ -472,7 +473,7 @@ let iterator ~transl_exp ~scopes ~loc | Texp_comp_in { pattern; sequence = iter_arr_exp } -> let iter_arr = Let_binding.make (Immutable Strict) (Pvalue Pgenval) - "iter_arr" (transl_exp ~scopes iter_arr_exp) + "iter_arr" (transl_exp ~scopes Sort.for_predef_value iter_arr_exp) in let iter_arr_kind = Typeopt.array_kind iter_arr_exp in let iter_len = @@ -486,7 +487,7 @@ let iterator ~transl_exp ~scopes ~loc let mk_iterator body = let open (val Lambda_utils.int_ops ~loc) in (* for iter_ix = 0 to Array.length iter_arr - 1 ... *) - (* CR layouts: will need updating when we allow non-values in arrays. *) + (* CR layouts v4: will need updating when we allow non-values in arrays. *) Lfor { for_id = iter_ix ; for_from = l0 ; for_to = iter_len.var - l1 @@ -494,13 +495,14 @@ let iterator ~transl_exp ~scopes ~loc ; for_body = Matching.for_let ~scopes + ~arg_sort:Sort.for_array_element + ~return_layout:(Pvalue Pintval) pattern.pat_loc (Lprim(Parrayrefu Lambda.(array_ref_kind alloc_heap iter_arr_kind), [iter_arr.var; Lvar iter_ix], loc)) pattern - (Pvalue Pintval) body } in @@ -549,7 +551,7 @@ let clause ~transl_exp ~scopes ~loc = function (Iterator_bindings.all_let_bindings var_bindings) (make_clause body) | Texp_comp_when cond -> - fun body -> Lifthenelse(transl_exp ~scopes cond, + fun body -> Lifthenelse(transl_exp ~scopes Sort.for_predef_value cond, body, lambda_unit, (Pvalue Pintval) (* [unit] is immediate *)) @@ -830,7 +832,7 @@ let comprehension ~array_sizing ~array ~index - ~body:(transl_exp ~scopes comp_body)), + ~body:(transl_exp ~scopes Sort.for_array_element comp_body)), (* If it was dynamically grown, cut it down to size *) match array_sizing with | Fixed_size -> array.var diff --git a/ocaml/lambda/transl_array_comprehension.mli b/ocaml/lambda/transl_array_comprehension.mli index 064079879ab..4e50a627d21 100644 --- a/ocaml/lambda/transl_array_comprehension.mli +++ b/ocaml/lambda/transl_array_comprehension.mli @@ -22,7 +22,7 @@ open Debuginfo.Scoped_location so is parameterized by [Translcore.transl_exp], its [scopes] argument, and the [loc]ation. *) val comprehension - : transl_exp:(scopes:scopes -> expression -> lambda) + : transl_exp:(scopes:scopes -> Layouts.sort -> expression -> lambda) -> scopes:scopes -> loc:scoped_location -> array_kind:array_kind diff --git a/ocaml/lambda/transl_comprehension_utils.ml b/ocaml/lambda/transl_comprehension_utils.ml index 8b0dc95d15f..381ff6b3c60 100644 --- a/ocaml/lambda/transl_comprehension_utils.ml +++ b/ocaml/lambda/transl_comprehension_utils.ml @@ -112,7 +112,9 @@ module Lambda_utils = struct module Primitive = struct (** The Lambda primitive for calling a simple C primitive *) - let c_prim name arity = Pccall (Primitive.simple ~name ~arity ~alloc:true) + (* CR layouts v4: To change when non-values are allowed in arrays. *) + let c_prim name arity = + Pccall (Primitive.simple_on_values ~name ~arity ~alloc:true) (** Create a function that produces the Lambda representation for a one-argument C primitive when provided with a Lambda argument *) diff --git a/ocaml/lambda/transl_list_comprehension.ml b/ocaml/lambda/transl_list_comprehension.ml index 89f9646397a..eb705471204 100644 --- a/ocaml/lambda/transl_list_comprehension.ml +++ b/ocaml/lambda/transl_list_comprehension.ml @@ -1,3 +1,4 @@ +open Layouts open Lambda open Typedtree open Asttypes @@ -165,11 +166,6 @@ type translated_iterator = desugars into a higher-order function which is applied to another function containing the body of the iteration; that body function can't be filled in until the rest of the translations have been done. *) -(* CR layouts v2: the value that is passed to this function for [transl_exp] - (and all the other [~transl_exp] parameters in this file) must only be called - on expressions whose types have sort value. Probably [transl_exp] will have - been updated to allow other sorts by the time we allow array elements other - than value, but check that. *) let iterator ~transl_exp ~scopes = function | Texp_comp_range { ident; pattern = _; start; stop; direction } -> (* We have to let-bind [start] and [stop] so that they're evaluated in the @@ -177,7 +173,7 @@ let iterator ~transl_exp ~scopes = function let transl_bound var bound = Let_binding.make (Immutable Strict) (Pvalue Pintval) - var (transl_exp ~scopes bound) + var (transl_exp ~scopes Sort.for_predef_value bound) in let start = transl_bound "start" start in let stop = transl_bound "stop" stop in @@ -192,7 +188,7 @@ let iterator ~transl_exp ~scopes = function | Texp_comp_in { pattern; sequence } -> let iter_list = Let_binding.make (Immutable Strict) (Pvalue Pgenval) - "iter_list" (transl_exp ~scopes sequence) + "iter_list" (transl_exp ~scopes Sort.for_predef_value sequence) in (* Create a fresh variable to use as the function argument *) let element = Ident.create_local "element" in @@ -200,11 +196,14 @@ let iterator ~transl_exp ~scopes = function ; arg_lets = [iter_list] ; element ; element_kind = - Typeopt.layout pattern.pat_env pattern.pat_loc pattern.pat_type + Typeopt.layout pattern.pat_env pattern.pat_loc + Layouts.Sort.for_list_element pattern.pat_type ; add_bindings = (* CR layouts: to change when we allow non-values in sequences *) Matching.for_let - ~scopes pattern.pat_loc (Lvar element) pattern (Pvalue Pgenval) + ~scopes ~arg_sort:Sort.for_list_element + ~return_layout:(Pvalue Pgenval) pattern.pat_loc (Lvar element) + pattern } (** Translates a list comprehension binding @@ -289,7 +288,7 @@ let rec translate_clauses in Let_binding.let_all arg_lets bindings | Texp_comp_when cond -> - Lifthenelse(transl_exp ~scopes cond, + Lifthenelse(transl_exp ~scopes Sort.for_predef_value cond, body ~accumulator, accumulator, (Pvalue Pgenval) (* [list]s have the standard representation *)) @@ -304,7 +303,7 @@ let comprehension ~transl_exp ~scopes ~loc { comp_body; comp_clauses } = rev_list_snoc_local ~loc ~init:accumulator - ~last:(transl_exp ~scopes comp_body)) + ~last:(transl_exp ~scopes Sort.for_list_element comp_body)) ~accumulator:rev_list_nil comp_clauses in diff --git a/ocaml/lambda/transl_list_comprehension.mli b/ocaml/lambda/transl_list_comprehension.mli index 3369e08776c..bc564dc4767 100644 --- a/ocaml/lambda/transl_list_comprehension.mli +++ b/ocaml/lambda/transl_list_comprehension.mli @@ -15,7 +15,7 @@ open Debuginfo.Scoped_location so is parameterized by [Translcore.transl_exp], its [scopes] argument, and the [loc]ation. *) val comprehension - : transl_exp:(scopes:scopes -> expression -> lambda) + : transl_exp:(scopes:scopes -> Layouts.sort -> expression -> lambda) -> scopes:scopes -> loc:scoped_location -> comprehension diff --git a/ocaml/lambda/translclass.ml b/ocaml/lambda/translclass.ml index 39021e1cbf5..a24eeae0b4e 100644 --- a/ocaml/lambda/translclass.ml +++ b/ocaml/lambda/translclass.ml @@ -14,6 +14,7 @@ (**************************************************************************) open Asttypes +open Layouts open Types open Typedtree open Lambda @@ -98,7 +99,8 @@ let transl_meth_list lst = let set_inst_var ~scopes obj id expr = Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment modify_heap), - [Lvar obj; Lvar id; transl_exp ~scopes expr], Loc_unknown) + [Lvar obj; Lvar id; transl_exp ~scopes Sort.for_instance_var expr], + Loc_unknown) let transl_val tbl create name = mkappl (oo_prim (if create then "new_variable" else "get_variable"), @@ -204,16 +206,22 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = (inh_init, let build params rem = let param = name_pattern "param" pat in - let param_layout = - Typeopt.layout pat.pat_env pat.pat_loc pat.pat_type + let arg_sort = Sort.for_class_arg in + let arg_layout = + Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type + in + let body = + Matching.for_function ~scopes ~arg_sort ~arg_layout + ~return_layout:layout_obj pat.pat_loc None (Lvar param) [pat, rem] + partial in Lambda.lfunction - ~kind:(Curried {nlocal=0}) ~params:((param, param_layout)::params) + ~kind:(Curried {nlocal=0}) + ~params:((param, arg_layout)::params) ~return:layout_obj ~attr:default_function_attribute ~loc:(of_location ~scopes pat.pat_loc) - ~body:(Matching.for_function ~scopes layout_obj pat.pat_loc - None (Lvar param, param_layout) [pat, rem] partial) + ~body ~mode:alloc_heap ~region:true in @@ -233,7 +241,8 @@ let rec build_object_init ~scopes cl_table obj params inh_init obj_init cl = build_object_init ~scopes cl_table obj (vals @ params) inh_init obj_init cl in - (inh_init, Translcore.transl_let ~scopes rec_flag defs layout_obj obj_init) + (inh_init, Translcore.transl_let ~return_layout:layout_obj ~scopes + rec_flag defs obj_init) | Tcl_open (_, cl) | Tcl_constraint (cl, _, _, _, _) -> build_object_init ~scopes cl_table obj params inh_init obj_init cl @@ -350,7 +359,8 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = | Tcf_method (name, _, Tcfk_concrete (_, exp)) -> let scopes = enter_method_definition ~scopes name.txt in let met_code = - msubst true (transl_scoped_exp ~scopes exp) in + msubst true (transl_scoped_exp ~scopes Sort.for_method exp) + in let met_code = if !Clflags.native_code && List.length met_code = 1 then (* Force correct naming of method for profiles *) @@ -365,7 +375,9 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = (inh_init, Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false - (transl_exp ~scopes exp), layout_unit), + (transl_exp ~scopes + Sort.for_initializer exp), + layout_unit), cl_init), methods, values) | Tcf_attribute _ -> @@ -445,8 +457,9 @@ let rec build_class_lets ~scopes cl = match cl.cl_desc with Tcl_let (rec_flag, defs, _vals, cl') -> let env, wrap = build_class_lets ~scopes cl' in - (env, fun x_layout x -> - Translcore.transl_let ~scopes rec_flag defs x_layout (wrap x_layout x)) + (env, fun return_layout x -> + Translcore.transl_let ~scopes ~return_layout rec_flag defs + (wrap return_layout x)) | _ -> (cl.cl_env, fun _ x -> x) @@ -481,17 +494,22 @@ let rec transl_class_rebind ~scopes obj_init cl vf = transl_class_rebind ~scopes obj_init cl vf in let build params rem = let param = name_pattern "param" pat in - let param_layout = - Typeopt.layout pat.pat_env pat.pat_loc pat.pat_type + let arg_sort = Sort.for_class_arg in + let arg_layout = + Typeopt.layout pat.pat_env pat.pat_loc arg_sort pat.pat_type in let return_layout = layout_class in + let body = + Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout pat.pat_loc + None (Lvar param) [pat, rem] partial + in Lambda.lfunction - ~kind:(Curried {nlocal=0}) ~params:((param, param_layout)::params) + ~kind:(Curried {nlocal=0}) + ~params:((param, arg_layout)::params) ~return:return_layout ~attr:default_function_attribute ~loc:(of_location ~scopes pat.pat_loc) - ~body:(Matching.for_function ~scopes return_layout pat.pat_loc - None (Lvar param, param_layout) [pat, rem] partial) + ~body ~mode:alloc_heap ~region:true in @@ -509,7 +527,8 @@ let rec transl_class_rebind ~scopes obj_init cl vf = let path, path_lam, obj_init = transl_class_rebind ~scopes obj_init cl vf in (path, path_lam, - Translcore.transl_let ~scopes rec_flag defs layout_obj obj_init) + Translcore.transl_let ~scopes ~return_layout:layout_obj rec_flag defs + obj_init) | Tcl_structure _ -> raise Exit | Tcl_constraint (cl', _, _, _, _) -> let path, path_lam, obj_init = @@ -531,7 +550,8 @@ let rec transl_class_rebind_0 ~scopes (self:Ident.t) obj_init cl vf = transl_class_rebind_0 ~scopes self obj_init cl vf in (path, path_lam, - Translcore.transl_let ~scopes rec_flag defs layout_obj obj_init) + Translcore.transl_let ~scopes ~return_layout:layout_obj rec_flag defs + obj_init) | _ -> let path, path_lam, obj_init = transl_class_rebind ~scopes obj_init cl vf in diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 9e5c387eb68..da004126656 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -32,45 +32,31 @@ type error = | Unreachable_reached | Bad_probe_layout of Ident.t | Non_value_layout of Layout.Violation.t + | Void_sort of type_expr exception Error of Location.t * error let use_dup_for_constant_mutable_arrays_bigger_than = 4 -(* CR layouts v2: When we're ready to allow non-values, these can be deleted or - changed to check for void. *) -let sort_must_be_value ~why loc sort = - if not Sort.(equate sort value) then - let violation = Layout.(Violation.of_ (Not_a_sublayout - (of_sort ~why sort, - value ~why:V1_safety_check))) in - raise (Error (loc, Non_value_layout violation)) - let layout_must_be_value loc layout = match Layout.(sub layout (value ~why:V1_safety_check)) with | Ok _ -> () | Error e -> raise (Error (loc, Non_value_layout e)) -(* CR layouts v2: In the places where this is used, we want to allow any (the - left of a semicolon and loop bodies). So we want this instead of the usual - sanity check for value. But we still default to value before checking for - void, to allow for sort variables arising in situations like +(* CR layouts v2: In the places where this is used, we will want to allow + #float, but not void yet (e.g., the left of a semicolon and loop bodies). we + still default to value before checking for void, to allow for sort variables + arising in situations like let foo () = raise Foo; () When this sanity check is removed, consider whether we are still defaulting appropriately. *) -let layout_must_not_be_void loc layout = - Layout.default_to_value layout; - match Layout.(sub layout (void ~why:V1_safety_check)) with - | Ok _ -> - let violation = Layout.(Violation.of_ (Not_a_sublayout - (layout, value ~why:V1_safety_check))) in - raise (Error (loc, Non_value_layout violation)) - | Error _ -> () +let sort_must_not_be_void loc ty sort = + if Sort.is_void_defaulting sort then raise (Error (loc, Void_sort ty)) -let layout_exp e = layout e.exp_env e.exp_loc e.exp_type +let layout_exp sort e = layout e.exp_env e.exp_loc sort e.exp_type (* Forward declaration -- to be filled in by Translmod.transl_module *) let transl_module = @@ -95,7 +81,8 @@ let declare_probe_handlers lam = (* Compile an exception/extension definition *) let prim_fresh_oo_id = - Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) + Pccall + (Primitive.simple_on_values ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false) let transl_extension_constructor ~scopes env path ext = let path = @@ -203,8 +190,8 @@ let maybe_region get_layout lam = let maybe_region_layout layout lam = maybe_region (fun () -> layout) lam -let maybe_region_exp exp lam = - maybe_region (fun () -> layout_exp exp) lam +let maybe_region_exp sort exp lam = + maybe_region (fun () -> layout_exp sort exp) lam (* Push the default values under the functional abstractions *) @@ -226,23 +213,30 @@ let rec trivial_pat pat = List.for_all trivial_pat patl | _ -> false -let rec push_defaults loc bindings use_lhs arg_mode cases partial warnings = +let rec push_defaults loc bindings use_lhs arg_mode arg_sort cases + partial warnings = match cases with [{c_lhs=pat; c_guard=None; c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; - region; curry; warnings; arg_mode; alloc_mode } } + region; curry; warnings; arg_mode; + arg_sort; ret_sort; alloc_mode } } as exp}] when bindings = [] || trivial_pat pat -> - let cases = push_defaults exp.exp_loc bindings false arg_mode cases partial warnings in + let cases = + push_defaults exp.exp_loc bindings false arg_mode arg_sort cases partial + warnings + in [{c_lhs=pat; c_guard=None; - c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases; - partial; region; curry; warnings; arg_mode; alloc_mode }}}] + c_rhs={exp with exp_desc = + Texp_function { arg_label; param; cases; partial; + region; curry; warnings; arg_mode; + arg_sort; ret_sort; alloc_mode }}}] | [{c_lhs=pat; c_guard=None; c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}]; exp_desc = Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] -> push_defaults loc (binds :: bindings) true - arg_mode [{c_lhs=pat;c_guard=None;c_rhs=e2}] + arg_mode arg_sort [{c_lhs=pat;c_guard=None;c_rhs=e2}] partial warnings | [{c_lhs=pat; c_guard=None; c_rhs=exp} as case] when use_lhs || trivial_pat pat && exp.exp_desc <> Texp_unreachable -> @@ -268,9 +262,7 @@ let rec push_defaults loc bindings use_lhs arg_mode cases partial warnings = Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), desc, Id_value)}, - Sort.value, - (* CR layouts v2: Value here will changes when functions take other - layouts. Maybe we need a sort in [Typedtree.case]? *) + arg_sort, cases, partial) } in [{c_lhs = {pat with pat_desc = Tpat_var (param, mknoloc name, mode)}; @@ -321,11 +313,6 @@ let assert_failed ~scopes exp = Const_base(Const_int char)]))], loc))], loc) ;; -let rec cut n l = - if n = 0 then ([],l) else - match l with [] -> failwith "Translcore.cut" - | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2) - (* Translation of expressions *) let rec iter_exn_names f pat = @@ -363,27 +350,25 @@ let can_apply_primitive p pmode pos args = end end -(* CR layouts v2: Invariant - this is only called on values. Relax that. *) -let rec transl_exp ~scopes e = - transl_exp1 ~scopes ~in_new_scope:false e +let rec transl_exp ~scopes sort e = + transl_exp1 ~scopes ~in_new_scope:false sort e (* ~in_new_scope tracks whether we just opened a new scope. We go to some trouble to avoid introducing many new anonymous function scopes, as `let f a b = ...` is desugared to several Pexp_fun. *) -(* CR layouts v2: Invariant - this is only called on values. Relax that. *) -and transl_exp1 ~scopes ~in_new_scope e = +and transl_exp1 ~scopes ~in_new_scope sort e = let eval_once = (* Whether classes for immediate objects must be cached *) match e.exp_desc with Texp_function _ | Texp_for _ | Texp_while _ -> false | _ -> true in - if eval_once then transl_exp0 ~scopes ~in_new_scope e else - Translobj.oo_wrap e.exp_env true (transl_exp0 ~scopes ~in_new_scope) e + if eval_once then transl_exp0 ~scopes ~in_new_scope sort e else + Translobj.oo_wrap e.exp_env true (transl_exp0 ~scopes ~in_new_scope sort) e -and transl_exp0 ~in_new_scope ~scopes e = +and transl_exp0 ~in_new_scope ~scopes sort e = match e.exp_desc with | Texp_ident(path, _, desc, kind) -> transl_ident (of_location ~scopes e.exp_loc) @@ -391,31 +376,32 @@ and transl_exp0 ~in_new_scope ~scopes e = | Texp_constant cst -> Lconst(Const_base cst) | Texp_let(rec_flag, pat_expr_list, body) -> - let body_layout = layout_exp body in - transl_let ~scopes rec_flag pat_expr_list - body_layout (event_before ~scopes body (transl_exp ~scopes body)) - | Texp_function { arg_label = _; param; cases; partial; - region; curry; warnings; arg_mode; alloc_mode } -> - (* CR ncourant: it would be better if we had [arg_layout] here *) - let arg_layout = - match is_function_type e.exp_env e.exp_type with - | None -> Misc.fatal_error "Translcore.transl_exp0: Type of a function is not a function type" - | Some (arg_type, _) -> - Typeopt.layout e.exp_env e.exp_loc arg_type - in + let return_layout = layout_exp sort body in + transl_let ~scopes ~return_layout rec_flag pat_expr_list + (event_before ~scopes body (transl_exp ~scopes sort body)) + | Texp_function { arg_label = _; param; cases; partial; region; curry; + warnings; arg_mode; arg_sort; ret_sort; alloc_mode } -> let scopes = if in_new_scope then scopes else enter_anonymous_function ~scopes in - transl_function ~scopes e alloc_mode param arg_mode arg_layout cases partial warnings region curry + transl_function ~scopes e alloc_mode param arg_mode arg_sort ret_sort + cases partial warnings region curry | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}, Id_prim pmode); exp_type = prim_type; } as funct, oargs, pos, alloc_mode) when can_apply_primitive p pmode pos oargs -> - let argl, extra_args = cut p.prim_arity oargs in - let arg_exps = - List.map (function _, Arg x -> x | _ -> assert false) argl + let rec cut_args prim_repr oargs = + match prim_repr, oargs with + | [], _ -> [], oargs + | _, [] -> failwith "Translcore cut_args" + | ((_, arg_repr) :: prim_repr), ((_, Arg (x, _)) :: oargs) -> + let arg_exps, extra_args = cut_args prim_repr oargs in + let arg_sort = Sort.of_const (sort_of_native_repr arg_repr) in + (x, arg_sort) :: arg_exps, extra_args + | _, ((_, Omitted _) :: _) -> assert false in + let arg_exps, extra_args = cut_args p.prim_native_repr_args oargs in let args = transl_list ~scopes arg_exps in let prim_exp = if extra_args = [] then Some e else None in let position = @@ -425,7 +411,7 @@ and transl_exp0 ~in_new_scope ~scopes e = let lam = Translprim.transl_primitive_application (of_location ~scopes e.exp_loc) p e.exp_env prim_type pmode - path prim_exp args arg_exps position + path prim_exp args (List.map fst arg_exps) position in if extra_args = [] then lam else begin @@ -434,7 +420,7 @@ and transl_exp0 ~in_new_scope ~scopes e = let specialised = Translattribute.get_specialised_attribute funct in let position = transl_apply_position pos in let mode = transl_alloc_mode alloc_mode in - let result_layout = layout_exp e in + let result_layout = layout_exp sort e in event_after ~scopes e (transl_apply ~scopes ~tailcall ~inlined ~specialised ~position ~mode ~result_layout lam extra_args (of_location ~scopes e.exp_loc)) @@ -443,24 +429,28 @@ and transl_exp0 ~in_new_scope ~scopes e = let tailcall = Translattribute.get_tailcall_attribute funct in let inlined = Translattribute.get_inlined_attribute funct in let specialised = Translattribute.get_specialised_attribute funct in - let result_layout = layout_exp e in + let result_layout = layout_exp sort e in let position = transl_apply_position position in let mode = transl_alloc_mode alloc_mode in event_after ~scopes e (transl_apply ~scopes ~tailcall ~inlined ~specialised ~result_layout - ~position ~mode (transl_exp ~scopes funct) + ~position ~mode (transl_exp ~scopes Sort.for_function funct) oargs (of_location ~scopes e.exp_loc)) - | Texp_match(arg, sort, pat_expr_list, partial) -> - transl_match ~scopes e arg sort pat_expr_list partial + | Texp_match(arg, arg_sort, pat_expr_list, partial) -> + transl_match ~scopes ~arg_sort ~return_sort:sort e arg pat_expr_list + partial | Texp_try(body, pat_expr_list) -> let id = Typecore.name_cases "exn" pat_expr_list in - let layout = layout_exp e in - Ltrywith(transl_exp ~scopes body, id, - Matching.for_trywith ~scopes layout e.exp_loc (Lvar id) - (transl_cases_try ~scopes pat_expr_list), - layout) + let return_layout = layout_exp sort e in + Ltrywith(transl_exp ~scopes sort body, id, + Matching.for_trywith ~scopes ~return_layout e.exp_loc (Lvar id) + (transl_cases_try ~scopes sort pat_expr_list), + return_layout) | Texp_tuple (el, alloc_mode) -> - let ll, shape = transl_list_with_shape ~scopes el in + let ll, shape = + transl_list_with_shape ~scopes + (List.map (fun a -> (a, Sort.for_tuple_element)) el) + in begin try Lconst(Const_block(0, List.map extract_constant ll)) with Not_constant -> @@ -470,7 +460,10 @@ and transl_exp0 ~in_new_scope ~scopes e = (of_location ~scopes e.exp_loc)) end | Texp_construct(_, cstr, args, alloc_mode) -> - let ll, shape = transl_list_with_shape ~scopes args in + let ll, shape = + transl_list_with_shape ~scopes + (List.map (fun a -> (a, Sort.for_constructor_arg)) args) + in if cstr.cstr_inlined <> None then begin match ll with | [x] -> x | _ -> assert false @@ -512,7 +505,7 @@ and transl_exp0 ~in_new_scope ~scopes e = begin match arg with None -> Lconst(const_int tag) | Some (arg, alloc_mode) -> - let lam = transl_exp ~scopes arg in + let lam = transl_exp ~scopes Sort.for_poly_variant arg in try Lconst(Const_block(0, [const_int tag; extract_constant lam])) @@ -527,7 +520,7 @@ and transl_exp0 ~in_new_scope ~scopes e = (Option.map transl_alloc_mode alloc_mode) fields representation extended_expression | Texp_field(arg, _, lbl, alloc_mode) -> - let targ = transl_exp ~scopes arg in + let targ = transl_exp ~scopes Sort.for_record arg in let sem = match lbl.lbl_mut with | Immutable -> Reads_agree @@ -562,12 +555,16 @@ and transl_exp0 ~in_new_scope ~scopes e = | Record_inlined (_, Variant_extensible) -> Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, mode) in - Lprim(access, [transl_exp ~scopes arg; transl_exp ~scopes newval], + Lprim(access, [transl_exp ~scopes Sort.for_record arg; + transl_exp ~scopes Sort.for_record_field newval], of_location ~scopes e.exp_loc) | Texp_array (amut, expr_list, alloc_mode) -> let mode = transl_alloc_mode alloc_mode in let kind = array_kind e in - let ll = transl_list ~scopes expr_list in + let ll = + transl_list ~scopes + (List.map (fun e -> (e, Sort.for_array_element)) expr_list) + in let loc = of_location ~scopes e.exp_loc in let makearray mutability = Lprim (Pmakearray (kind, mutability, mode), ll, loc) @@ -642,35 +639,35 @@ and transl_exp0 ~in_new_scope ~scopes e = Transl_array_comprehension.comprehension ~transl_exp ~scopes ~loc ~array_kind comp | Texp_ifthenelse(cond, ifso, Some ifnot) -> - Lifthenelse(transl_exp ~scopes cond, - event_before ~scopes ifso (transl_exp ~scopes ifso), - event_before ~scopes ifnot (transl_exp ~scopes ifnot), - layout_exp e) + Lifthenelse(transl_exp ~scopes Sort.for_predef_value cond, + event_before ~scopes ifso (transl_exp ~scopes sort ifso), + event_before ~scopes ifnot (transl_exp ~scopes sort ifnot), + layout_exp sort e) | Texp_ifthenelse(cond, ifso, None) -> - Lifthenelse(transl_exp ~scopes cond, - event_before ~scopes ifso (transl_exp ~scopes ifso), + Lifthenelse(transl_exp ~scopes Sort.for_predef_value cond, + event_before ~scopes ifso (transl_exp ~scopes sort ifso), lambda_unit, Lambda.layout_unit) - | Texp_sequence(expr1, layout, expr2) -> - layout_must_not_be_void expr1.exp_loc layout; - Lsequence(transl_exp ~scopes expr1, - event_before ~scopes expr2 (transl_exp ~scopes expr2)) - | Texp_while {wh_body; wh_body_layout; wh_cond} -> - layout_must_not_be_void wh_body.exp_loc wh_body_layout; - let cond = transl_exp ~scopes wh_cond in - let body = transl_exp ~scopes wh_body in + | Texp_sequence(expr1, sort, expr2) -> + sort_must_not_be_void expr1.exp_loc expr1.exp_type sort; + Lsequence(transl_exp ~scopes sort expr1, + event_before ~scopes expr2 (transl_exp ~scopes sort expr2)) + | Texp_while {wh_body; wh_body_sort; wh_cond} -> + sort_must_not_be_void wh_body.exp_loc wh_body.exp_type wh_body_sort; + let cond = transl_exp ~scopes Sort.for_predef_value wh_cond in + let body = transl_exp ~scopes wh_body_sort wh_body in Lwhile { wh_cond = maybe_region_layout layout_int cond; wh_body = event_before ~scopes wh_body (maybe_region_layout layout_unit body); } - | Texp_for {for_id; for_from; for_to; for_dir; for_body; for_body_layout} -> - layout_must_not_be_void for_body.exp_loc for_body_layout; - let body = transl_exp ~scopes for_body in + | Texp_for {for_id; for_from; for_to; for_dir; for_body; for_body_sort} -> + sort_must_not_be_void for_body.exp_loc for_body.exp_type for_body_sort; + let body = transl_exp ~scopes for_body_sort for_body in Lfor { for_id; - for_from = transl_exp ~scopes for_from; - for_to = transl_exp ~scopes for_to; + for_from = transl_exp ~scopes Sort.for_predef_value for_from; + for_to = transl_exp ~scopes Sort.for_predef_value for_to; for_dir; for_body = event_before ~scopes for_body (maybe_region_layout layout_unit body); @@ -680,13 +677,13 @@ and transl_exp0 ~in_new_scope ~scopes e = let pos = transl_apply_position pos in let mode = transl_alloc_mode alloc_mode in let loc = of_location ~scopes e.exp_loc in - let layout = layout_exp e in + let layout = layout_exp sort e in match met with | Tmeth_val id -> - let obj = transl_exp ~scopes expr in + let obj = transl_exp ~scopes Sort.for_object expr in Lsend (Self, Lvar id, obj, [], pos, mode, loc, layout) | Tmeth_name nm -> - let obj = transl_exp ~scopes expr in + let obj = transl_exp ~scopes Sort.for_object expr in let (tag, cache) = Translobj.meth obj nm in let kind = if cache = [] then Public else Cached in Lsend (kind, tag, obj, cache, pos, mode, loc, layout) @@ -713,7 +710,7 @@ and transl_exp0 ~in_new_scope ~scopes e = Lprim(Pfield (0, Reads_vary), [transl_class_path loc e.exp_env cl], loc); ap_args=[lambda_unit]; - ap_result_layout=layout_exp e; + ap_result_layout=layout_exp sort e; ap_region_close=pos; ap_mode=alloc_heap; ap_tailcall=Default_tailcall; @@ -757,19 +754,20 @@ and transl_exp0 ~in_new_scope ~scopes e = | Texp_letmodule(None, loc, Mp_present, modl, body) -> let lam = !transl_module ~scopes Tcoerce_none None modl in Lsequence(Lprim(Pignore, [lam], of_location ~scopes loc.loc), - transl_exp ~scopes body) + transl_exp ~scopes sort body) | Texp_letmodule(Some id, _loc, Mp_present, modl, body) -> let defining_expr = let mod_scopes = enter_module_definition ~scopes id in !transl_module ~scopes:mod_scopes Tcoerce_none None modl in - Llet(Strict, Lambda.layout_module, id, defining_expr, transl_exp ~scopes body) + Llet(Strict, Lambda.layout_module, id, defining_expr, + transl_exp ~scopes sort body) | Texp_letmodule(_, _, Mp_absent, _, body) -> - transl_exp ~scopes body + transl_exp ~scopes sort body | Texp_letexception(cd, body) -> Llet(Strict, Lambda.layout_block, cd.ext_id, transl_extension_constructor ~scopes e.exp_env None cd, - transl_exp ~scopes body) + transl_exp ~scopes sort body) | Texp_pack modl -> !transl_module ~scopes Tcoerce_none None modl | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _, _)} -> @@ -779,7 +777,7 @@ and transl_exp0 ~in_new_scope ~scopes e = then lambda_unit else begin Lifthenelse - (transl_exp ~scopes cond, + (transl_exp ~scopes Sort.for_predef_value cond, lambda_unit, assert_failed ~scopes e, Lambda.layout_unit) @@ -792,14 +790,15 @@ and transl_exp0 ~in_new_scope ~scopes e = | `Constant_or_function -> (* A constant expr (of type <> float if [Config.flat_float_array] is true) gets compiled as itself. *) - transl_exp ~scopes e + transl_exp ~scopes Sort.for_lazy_body e | `Float_that_cannot_be_shortcut -> (* We don't need to wrap with Popaque: this forward block will never be shortcutted since it points to a float and Config.flat_float_array is true. *) Lprim(Pmakeblock(Obj.forward_tag, Immutable, None, alloc_heap), - [transl_exp ~scopes e], of_location ~scopes e.exp_loc) + [transl_exp ~scopes Sort.for_lazy_body e], + of_location ~scopes e.exp_loc) | `Identifier `Forward_value -> (* CR-someday mshinwell: Consider adding a new primitive that expresses the construction of forward_tag blocks. @@ -810,11 +809,11 @@ and transl_exp0 ~in_new_scope ~scopes e = Lprim (Popaque Lambda.layout_lazy, [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None, alloc_heap), - [transl_exp ~scopes e], + [transl_exp ~scopes Sort.for_lazy_body e], of_location ~scopes e.exp_loc)], of_location ~scopes e.exp_loc) | `Identifier `Other -> - transl_exp ~scopes e + transl_exp ~scopes Sort.for_lazy_body e | `Other -> (* other cases compile to a lazy block holding a function. The typechecker enforces that e has layout value. *) @@ -828,7 +827,7 @@ and transl_exp0 ~in_new_scope ~scopes e = ~region:true ~body:(maybe_region_layout Lambda.layout_lazy_contents - (transl_exp ~scopes e)) + (transl_exp ~scopes Sort.for_lazy_body e)) in Lprim(Pmakeblock(Config.lazy_tag, Mutable, None, alloc_heap), [fn], of_location ~scopes e.exp_loc) @@ -843,10 +842,11 @@ and transl_exp0 ~in_new_scope ~scopes e = cl_env = e.exp_env; cl_attributes = []; } - | Texp_letop{let_; ands; param; body; partial; warnings} -> + | Texp_letop{let_; ands; param; param_sort; body; body_sort; partial; + warnings} -> event_after ~scopes e (transl_letop ~scopes e.exp_loc e.exp_env let_ ands - param body partial warnings) + param param_sort body body_sort partial warnings) | Texp_unreachable -> raise (Error (e.exp_loc, Unreachable_reached)) | Texp_open (od, e) -> @@ -856,7 +856,7 @@ and transl_exp0 ~in_new_scope ~scopes e = But since [scan_used_globals] runs before Simplif, we need to do it. *) begin match od.open_bound_items with - | [] when pure = Alias -> transl_exp ~scopes e + | [] when pure = Alias -> transl_exp ~scopes sort e | _ -> let oid = Ident.create_local "open" in let body, _ = @@ -868,7 +868,7 @@ and transl_exp0 ~in_new_scope ~scopes e = Lprim(mod_field pos, [Lvar oid], of_location ~scopes od.open_loc), body), pos + 1 - ) (transl_exp ~scopes e, 0) + ) (transl_exp ~scopes sort e, 0) (bound_value_identifiers od.open_bound_items) in Llet(pure, Lambda.layout_module, oid, @@ -876,7 +876,7 @@ and transl_exp0 ~in_new_scope ~scopes e = end | Texp_probe {name; handler=exp; enabled_at_init} -> if !Clflags.native_code && !Clflags.probes then begin - let lam = transl_exp ~scopes exp in + let lam = transl_exp ~scopes Sort.for_probe_body exp in let map = Ident.Set.fold (fun v acc -> Ident.Map.add v (Ident.rename v) acc) (free_variables lam) @@ -899,8 +899,7 @@ and transl_exp0 ~in_new_scope ~scopes e = (We could probably calculate the layouts of these variables here rather than requiring them all to be value, but that would be even - more hacky, and in any event we don't yet want to connect the - front-end layout support to the middle-end layout support). *) + more hacky.) *) (* CR layouts v2: if we get close to releasing other layout somebody actually might put in a probe, check with the middle-end team about the status of fixing this. *) @@ -934,14 +933,15 @@ and transl_exp0 ~in_new_scope ~scopes e = tmc_candidate = false; } in let funcid = Ident.create_local ("probe_handler_" ^ name) in - let layout = layout_exp exp in - (* CR ncourant: how do we get the layouts for the free variables? *) + let return_layout = layout_unit (* Probe bodies have type unit. *) in let handler = let scopes = enter_value_definition ~scopes funcid in lfunction ~kind:(Curried {nlocal=0}) - ~params:(List.map (fun v -> v, Lambda.layout_top) param_idents) - ~return:layout + (* CR layouts: Adjust param layouts when we allow other things in + probes. *) + ~params:(List.map (fun v -> v, layout_probe_arg) param_idents) + ~return:return_layout ~body ~loc:(of_location ~scopes exp.exp_loc) ~attr @@ -951,7 +951,7 @@ and transl_exp0 ~in_new_scope ~scopes e = let app = { ap_func = Lvar funcid; ap_args = List.map (fun id -> Lvar id) arg_idents; - ap_result_layout = layout; + ap_result_layout = return_layout; ap_region_close = Rc_normal; ap_mode = alloc_heap; ap_loc = of_location e.exp_loc ~scopes; @@ -982,7 +982,7 @@ and transl_exp0 ~in_new_scope ~scopes e = else lambda_unit | Texp_exclave e -> - let l = transl_exp ~scopes e in + let l = transl_exp ~scopes sort e in if Config.stack_allocation then Lexclave l else l @@ -992,62 +992,60 @@ and pure_module m = | Tmod_constraint (m,_,_,_) -> pure_module m | _ -> Strict -(* List elements must have layout value (this does not check). *) and transl_list ~scopes expr_list = - List.map (transl_exp ~scopes) expr_list + List.map (fun (exp, sort) -> transl_exp ~scopes sort exp) expr_list -(* Will raise if a list element has a non-value layout. *) and transl_list_with_layout ~scopes expr_list = - List.map (fun exp -> transl_exp ~scopes exp, layout_exp exp) expr_list + List.map (fun (exp, sort) -> transl_exp ~scopes sort exp, + sort, + layout_exp sort exp) + expr_list (* Will raise if a list element has a non-value layout. *) and transl_list_with_shape ~scopes expr_list = - let transl_with_shape e = - let shape = Lambda.must_be_value (layout_exp e) in - transl_exp ~scopes e, shape + let transl_with_shape (e, sort) = + let shape = Lambda.must_be_value (layout_exp sort e) in + transl_exp ~scopes sort e, shape in List.split (List.map transl_with_shape expr_list) -(* Will raise if rhs has a non-value layout *) -and transl_guard ~scopes guard rhs = - let layout = layout_exp rhs in - let expr = event_before ~scopes rhs (transl_exp ~scopes rhs) in +and transl_guard ~scopes guard rhs_sort rhs = + let layout = layout_exp rhs_sort rhs in + let expr = event_before ~scopes rhs (transl_exp ~scopes rhs_sort rhs) in match guard with | None -> expr | Some cond -> event_before ~scopes cond - (Lifthenelse(transl_exp ~scopes cond, expr, staticfail, layout)) + (Lifthenelse(transl_exp ~scopes Sort.for_predef_value cond, + expr, staticfail, layout)) -(* will raise if c_rhs has a non-value layout *) -and transl_case ~scopes {c_lhs; c_guard; c_rhs} = - c_lhs, transl_guard ~scopes c_guard c_rhs +and transl_case ~scopes rhs_sort {c_lhs; c_guard; c_rhs} = + c_lhs, transl_guard ~scopes c_guard rhs_sort c_rhs -(* will raise if any cases have a non-value rhs *) -and transl_cases ~scopes cases = +and transl_cases ~scopes rhs_sort cases = let cases = List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in - List.map (transl_case ~scopes) cases + List.map (transl_case ~scopes rhs_sort) cases -(* will raise if the case has a non-value rhs *) -and transl_case_try ~scopes {c_lhs; c_guard; c_rhs} = +and transl_case_try ~scopes rhs_sort {c_lhs; c_guard; c_rhs} = iter_exn_names Translprim.add_exception_ident c_lhs; Misc.try_finally - (fun () -> c_lhs, transl_guard ~scopes c_guard c_rhs) + (fun () -> c_lhs, transl_guard ~scopes c_guard rhs_sort c_rhs) ~always:(fun () -> iter_exn_names Translprim.remove_exception_ident c_lhs) -(* will raise if any cases have a non-value rhs *) -and transl_cases_try ~scopes cases = +and transl_cases_try ~scopes rhs_sort cases = let cases = List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in - List.map (transl_case_try ~scopes) cases + List.map (transl_case_try ~scopes rhs_sort) cases -(* will raise if any cases have a non-value rhs *) -and transl_tupled_cases ~scopes patl_expr_list = +and transl_tupled_cases ~scopes rhs_sort patl_expr_list = let patl_expr_list = List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable) patl_expr_list in - List.map (fun (patl, guard, expr) -> (patl, transl_guard ~scopes guard expr)) + List.map + (fun (patl, guard, expr) -> + (patl, transl_guard ~scopes guard rhs_sort expr)) patl_expr_list and transl_apply ~scopes @@ -1098,7 +1096,7 @@ and transl_apply ~scopes } in let rec build_apply lam args loc pos ap_mode = function - | Omitted { mode_closure; mode_arg; mode_ret; ty_arg; ty_env } :: l -> + | Omitted { mode_closure; mode_arg; mode_ret; sort_arg } :: l -> assert (pos = Rc_normal); let defs = ref [] in let protect name (lam, layout) = @@ -1141,7 +1139,7 @@ and transl_apply ~scopes | Alloc_local -> false | Alloc_heap -> true in - let layout_arg = Typeopt.layout ty_env (to_location loc) ty_arg in + let layout_arg = layout_of_sort (to_location loc) sort_arg in lfunction ~kind:(Curried {nlocal}) ~params:[id_arg, layout_arg] ~return:result_layout ~body ~mode ~region ~attr:default_stub_attribute ~loc @@ -1157,17 +1155,18 @@ and transl_apply ~scopes (fun (_, arg) -> match arg with | Omitted _ as arg -> arg - | Arg exp -> Arg (transl_exp ~scopes exp, layout_exp exp)) + | Arg (exp, sort_arg) -> + Arg (transl_exp ~scopes sort_arg exp, layout_exp sort_arg exp)) sargs in build_apply lam [] loc position mode args and transl_curried_function - ~scopes loc return - repr ~region ~curry partial warnings (param:Ident.t) arg_layout cases = + ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc repr ~region + ~curry partial warnings (param:Ident.t) cases = let max_arity = Lambda.max_arity () in - let rec loop ~scopes loc return ~arity ~region ~curry - partial warnings (param:Ident.t) arg_layout cases = + let rec loop ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc + ~arity ~region ~curry partial warnings (param:Ident.t) cases = match curry, cases with More_args {partial_mode}, [{c_lhs=pat; c_guard=None; @@ -1176,25 +1175,23 @@ and transl_curried_function { arg_label = _; param = param'; cases = cases'; partial = partial'; region = region'; curry = curry'; - warnings = warnings' }; + warnings = warnings'; arg_sort; ret_sort }; exp_env; exp_type; exp_loc }}] when arity < max_arity -> (* Lfunctions must have local returns after the first local arg/ret *) if Parmatch.inactive ~partial pat then let partial_mode = transl_alloc_mode partial_mode in - let return_layout = function_return_layout exp_env exp_loc exp_type in - let arg_layout' = - match is_function_type exp_env exp_type with - | None -> - Misc.fatal_error "Translcore.transl_curried_function: \ - Type of Texp_function is not function" - | Some (lhs, _) -> layout exp_env exp_loc lhs - in - let ((fnkind, params, return, region), body) = - loop ~scopes exp_loc return_layout - ~arity:(arity + 1) ~region:region' ~curry:curry' - partial' warnings' param' arg_layout' cases' + let ((fnkind, params, return_layout, region), body) = + let return_layout = + function_return_layout exp_env exp_loc ret_sort exp_type + in + let arg_layout = + function_arg_layout exp_env exp_loc arg_sort exp_type + in + loop ~scopes ~arg_sort ~arg_layout ~return_sort:ret_sort + ~return_layout exp_loc ~arity:(arity + 1) ~region:region' + ~curry:curry' partial' warnings' param' cases' in let fnkind = match partial_mode, fnkind with @@ -1207,9 +1204,9 @@ and transl_curried_function assert (nlocal = List.length params); Curried {nlocal = nlocal + 1} in - ((fnkind, (param, arg_layout) :: params, return, region), - Matching.for_function ~scopes return_layout loc None (Lvar param, arg_layout) - [pat, body] partial) + ((fnkind, (param, arg_layout) :: params, return_layout, region), + Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc + None (Lvar param) [pat, body] partial) else begin begin match partial with | Total -> @@ -1220,19 +1217,20 @@ and transl_curried_function Warnings.restore prev | Partial -> () end; - transl_tupled_function ~scopes ~arity ~region ~curry - loc return repr partial param arg_layout cases + transl_tupled_function ~scopes ~arg_sort ~arg_layout + ~return_sort:ret_sort ~return_layout ~arity ~region ~curry loc repr + partial param cases end | curry, cases -> - transl_tupled_function ~scopes ~arity ~region ~curry - loc return repr partial param arg_layout cases + transl_tupled_function ~scopes ~arg_sort ~arg_layout ~return_sort + ~return_layout ~arity ~region ~curry loc repr partial param cases in - loop ~scopes loc return ~arity:1 ~region ~curry - partial warnings param arg_layout cases + loop ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc ~arity:1 + ~region ~curry partial warnings param cases and transl_tupled_function - ~scopes ~arity ~region ~curry loc return - repr partial (param:Ident.t) arg_layout cases = + ~scopes ~arg_layout ~arg_sort ~return_sort ~return_layout ~arity ~region + ~curry loc repr partial (param:Ident.t) cases = let partial_mode = match curry with | More_args {partial_mode} | Final_arg {partial_mode} -> @@ -1253,7 +1251,8 @@ and transl_tupled_function let kinds = match arg_layout with | Pvalue (Pvariant { consts = []; non_consts = [0, kinds] }) -> - (* CR layouts v2: to change when we have non-value args. *) + (* CR layouts v5: to change when we have non-value tuple + elements. *) List.map (fun vk -> Pvalue vk) kinds | _ -> Misc.fatal_error @@ -1265,24 +1264,24 @@ and transl_tupled_function in let params = List.map fst tparams in let body = - Matching.for_tupled_function ~scopes loc return params - (transl_tupled_cases ~scopes pats_expr_list) partial + Matching.for_tupled_function ~scopes ~return_layout loc params + (transl_tupled_cases ~scopes return_sort pats_expr_list) partial in let region = region || not (may_allocate_in_region body) in - ((Tupled, tparams, return, region), body) + ((Tupled, tparams, return_layout, region), body) with Matching.Cannot_flatten -> - transl_function0 ~scopes loc ~region ~partial_mode - return repr partial param arg_layout cases + transl_function0 ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout + loc ~region ~partial_mode repr partial param cases end - | _ -> transl_function0 ~scopes loc ~region ~partial_mode - return repr partial param arg_layout cases + | _ -> transl_function0 ~scopes ~arg_sort ~arg_layout ~return_sort + ~return_layout loc ~region ~partial_mode repr partial param cases and transl_function0 - ~scopes loc ~region ~partial_mode return - repr partial (param:Ident.t) arg_layout cases = + ~scopes ~arg_sort ~arg_layout ~return_sort ~return_layout loc ~region + ~partial_mode repr partial (param:Ident.t) cases = let body = - Matching.for_function ~scopes return loc repr (Lvar param, arg_layout) - (transl_cases ~scopes cases) partial + Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout loc + repr (Lvar param) (transl_cases ~scopes return_sort cases) partial in let region = region || not (may_allocate_in_region body) in let nlocal = @@ -1291,19 +1290,26 @@ and transl_function0 | Alloc_local -> 1 | Alloc_heap -> 0 in - ((Curried {nlocal}, [param, arg_layout], return, region), body) + ((Curried {nlocal}, [param, arg_layout], return_layout, region), body) -and transl_function ~scopes e alloc_mode param arg_mode arg_layout cases partial warnings region curry = +and transl_function ~scopes e alloc_mode param arg_mode arg_sort return_sort + cases partial warnings region curry = let mode = transl_alloc_mode alloc_mode in + let arg_layout = + function_arg_layout e.exp_env e.exp_loc arg_sort e.exp_type + in let ((kind, params, return, region), body) = event_function ~scopes e (function repr -> - let pl = push_defaults e.exp_loc arg_mode cases partial warnings in + let pl = + push_defaults e.exp_loc arg_mode arg_sort cases partial warnings + in let return_layout = - function_return_layout e.exp_env e.exp_loc e.exp_type + function_return_layout e.exp_env e.exp_loc return_sort e.exp_type in - transl_curried_function ~scopes e.exp_loc return_layout - repr ~region ~curry partial warnings param arg_layout pl) + transl_curried_function ~arg_sort ~arg_layout ~return_sort + ~return_layout ~scopes e.exp_loc repr ~region ~curry partial warnings + param pl) in let attr = default_function_attribute in let loc = of_location ~scopes e.exp_loc in @@ -1324,13 +1330,11 @@ and transl_function ~scopes e alloc_mode param arg_mode arg_layout cases partial Translattribute.add_function_attributes lam e.exp_loc attrs (* Like transl_exp, but used when a new scope was just introduced. *) -(* CR layouts v2: Invariant - this is only called on values. Relax that. *) -and transl_scoped_exp ~scopes expr = - transl_exp1 ~scopes ~in_new_scope:true expr +and transl_scoped_exp ~scopes sort expr = + transl_exp1 ~scopes ~in_new_scope:true sort expr (* Decides whether a pattern binding should introduce a new scope. *) -(* CR layouts v2: Invariant - this is only called on values. Relax that. *) -and transl_bound_exp ~scopes ~in_structure pat expr = +and transl_bound_exp ~scopes ~in_structure pat sort expr = let should_introduce_scope = match expr.exp_desc with | Texp_function _ -> true @@ -1338,8 +1342,8 @@ and transl_bound_exp ~scopes ~in_structure pat expr = | _ -> false in match pat_bound_idents pat with | (id :: _) when should_introduce_scope -> - transl_scoped_exp ~scopes:(enter_value_definition ~scopes id) expr - | _ -> transl_exp ~scopes expr + transl_scoped_exp ~scopes:(enter_value_definition ~scopes id) sort expr + | _ -> transl_exp ~scopes sort expr (* Notice: transl_let consumes (ie compiles) its pat_expr_list argument, @@ -1347,8 +1351,8 @@ and transl_bound_exp ~scopes ~in_structure pat expr = This complication allows choosing any compilation order for the bindings and body of let constructs. *) -and transl_let ~scopes ?(add_regions=false) ?(in_structure=false) - rec_flag pat_expr_list body_kind = +and transl_let ~scopes ~return_layout ?(add_regions=false) ?(in_structure=false) + rec_flag pat_expr_list = match rec_flag with Nonrecursive -> let rec transl = function @@ -1356,15 +1360,15 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false) fun body -> body | {vb_pat=pat; vb_expr=expr; vb_sort=sort; vb_attributes=attr; vb_loc} :: rem -> - (* CR layouts v2: allow non-values. Either remove this or replace - with void-specific sanity check. *) - sort_must_be_value ~why:Let_binding expr.exp_loc sort; - let lam = transl_bound_exp ~scopes ~in_structure pat expr in + let lam = transl_bound_exp ~scopes ~in_structure pat sort expr in let lam = Translattribute.add_function_attributes lam vb_loc attr in - let lam = if add_regions then maybe_region_exp expr lam else lam in + let lam = + if add_regions then maybe_region_exp sort expr lam else lam + in let mk_body = transl rem in fun body -> - Matching.for_let ~scopes pat.pat_loc lam pat body_kind (mk_body body) + Matching.for_let ~scopes ~arg_sort:sort ~return_layout pat.pat_loc + lam pat (mk_body body) in transl pat_expr_list | Recursive -> @@ -1376,21 +1380,22 @@ and transl_let ~scopes ?(add_regions=false) ?(in_structure=false) pat_expr_list in let transl_case {vb_expr=expr; vb_sort; vb_attributes; vb_loc; vb_pat} id = - (* CR layouts v2: allow non-values. Either remove this or replace - with void-specific sanity check. *) - sort_must_be_value ~why:Let_binding expr.exp_loc vb_sort; - let lam = transl_bound_exp ~scopes ~in_structure vb_pat expr in + let lam = + transl_bound_exp ~scopes ~in_structure vb_pat vb_sort expr + in let lam = Translattribute.add_function_attributes lam vb_loc vb_attributes in - let lam = if add_regions then maybe_region_exp expr lam else lam in + let lam = + if add_regions then maybe_region_exp vb_sort expr lam else lam + in (id, lam) in let lam_bds = List.map2 transl_case pat_expr_list idlist in fun body -> Lletrec(lam_bds, body) and transl_setinstvar ~scopes loc self var expr = Lprim(Psetfield_computed (maybe_pointer expr, Assignment modify_heap), - [self; var; transl_exp ~scopes expr], loc) + [self; var; transl_exp ~scopes Sort.for_instance_var expr], loc) (* CR layouts v5: Invariant - this is only called on values. Relax that. *) and transl_record ~scopes loc env mode fields repres opt_init_expr = @@ -1414,7 +1419,9 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = (fun i (lbl, definition) -> match definition with | Kept typ -> - let field_kind = must_be_value (layout env lbl.lbl_loc typ) in + let field_kind = + must_be_value (layout env lbl.lbl_loc Sort.for_record_field typ) + in let sem = match lbl.lbl_mut with | Immutable -> Reads_agree @@ -1435,8 +1442,10 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = of_location ~scopes loc), field_kind | Overridden (_lid, expr) -> - let field_kind = must_be_value (layout_exp expr) in - transl_exp ~scopes expr, field_kind) + let field_kind = + must_be_value (layout_exp Sort.for_record_field expr) + in + transl_exp ~scopes Sort.for_record_field expr, field_kind) fields in let ll, shape = List.split (Array.to_list lv) in @@ -1482,7 +1491,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = begin match opt_init_expr with None -> lam | Some init_expr -> Llet(Strict, Lambda.layout_block, init_id, - transl_exp ~scopes init_expr, lam) + transl_exp ~scopes Sort.for_record init_expr, lam) end end else begin (* Take a shallow copy of the init record, then mutate the fields @@ -1510,7 +1519,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = let ptr = maybe_pointer expr in Psetfield(pos, ptr, Assignment modify_heap) in - Lsequence(Lprim(upd, [Lvar copy_id; transl_exp ~scopes expr], + Lsequence(Lprim(upd, [Lvar copy_id; + transl_exp ~scopes Sort.for_record_field expr], of_location ~scopes loc), cont) in @@ -1519,14 +1529,15 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr = | Some init_expr -> assert (is_heap_mode (Option.get mode)); (* Pduprecord must be Alloc_heap and not unboxed *) Llet(Strict, Lambda.layout_block, copy_id, - Lprim(Pduprecord (repres, size), [transl_exp ~scopes init_expr], + Lprim(Pduprecord (repres, size), + [transl_exp ~scopes Sort.for_record init_expr], of_location ~scopes loc), Array.fold_left update_field (Lvar copy_id) fields) end end -and transl_match ~scopes e arg sort pat_expr_list partial = - let layout = layout_exp e in +and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = + let return_layout = layout_exp arg_sort e in let rewrite_case (val_cases, exn_cases, static_handlers as acc) ({ c_lhs; c_guard; c_rhs } as case) = if c_rhs.exp_desc = Texp_unreachable then acc else @@ -1535,11 +1546,13 @@ and transl_match ~scopes e arg sort pat_expr_list partial = | None, None -> assert false | Some pv, None -> let val_case = - transl_case ~scopes { case with c_lhs = pv } + transl_case ~scopes return_sort { case with c_lhs = pv } in val_case :: val_cases, exn_cases, static_handlers | None, Some pe -> - let exn_case = transl_case_try ~scopes { case with c_lhs = pe } in + let exn_case = + transl_case_try ~scopes return_sort { case with c_lhs = pe } + in val_cases, exn_case :: exn_cases, static_handlers | Some pv, Some pe -> assert (c_guard = None); @@ -1549,11 +1562,11 @@ and transl_match ~scopes e arg sort pat_expr_list partial = in (* Simplif doesn't like it if binders are not uniq, so we make sure to use different names in the value and the exception branches. *) - let ids_full = Typedtree.pat_bound_idents_full sort pv in + let ids_full = Typedtree.pat_bound_idents_full arg_sort pv in let ids = List.map (fun (id, _, _, _) -> id) ids_full in let ids_kinds = - List.map (fun (id, {Location.loc; _}, ty, _) -> - id, Typeopt.layout pv.pat_env loc ty) + List.map (fun (id, {Location.loc; _}, ty, s) -> + id, Typeopt.layout pv.pat_env loc s ty) ids_full in let vids = List.map Ident.rename ids in @@ -1563,7 +1576,7 @@ and transl_match ~scopes e arg sort pat_expr_list partial = let rhs = Misc.try_finally (fun () -> event_before ~scopes c_rhs - (transl_exp ~scopes c_rhs)) + (transl_exp ~scopes return_sort c_rhs)) ~always:(fun () -> iter_exn_names Translprim.remove_exception_ident pe) in @@ -1597,51 +1610,54 @@ and transl_match ~scopes e arg sort pat_expr_list partial = let static_exception_id = next_raise_count () in Lstaticcatch (Ltrywith (Lstaticraise (static_exception_id, scrutinees), id, - Matching.for_trywith ~scopes layout e.exp_loc (Lvar id) exn_cases, - layout), + Matching.for_trywith ~scopes ~return_layout e.exp_loc (Lvar id) + exn_cases, + return_layout), (static_exception_id, val_ids), handler, - layout) + return_layout) in let classic = match arg, exn_cases with | {exp_desc = Texp_tuple (argl, alloc_mode)}, [] -> assert (static_handlers = []); let mode = transl_alloc_mode alloc_mode in - Matching.for_multiple_match ~scopes layout e.exp_loc + let argl = List.map (fun a -> (a, Sort.for_tuple_element)) argl in + Matching.for_multiple_match ~scopes ~return_layout e.exp_loc (transl_list_with_layout ~scopes argl) mode val_cases partial | {exp_desc = Texp_tuple (argl, alloc_mode)}, _ :: _ -> - let val_ids = + let argl = List.map (fun a -> (a, Sort.for_tuple_element)) argl in + let val_ids, lvars = List.map - (fun arg -> Typecore.name_pattern "val" [], layout_exp arg) + (fun (arg,s) -> + let layout = layout_exp s arg in + let id = Typecore.name_pattern "val" [] in + (id, layout), (Lvar id, s, layout)) argl + |> List.split in - let lvars = List.map (fun (id, layout) -> Lvar id, layout) val_ids in let mode = transl_alloc_mode alloc_mode in static_catch (transl_list ~scopes argl) val_ids - (Matching.for_multiple_match ~scopes layout e.exp_loc + (Matching.for_multiple_match ~scopes ~return_layout e.exp_loc lvars mode val_cases partial) | arg, [] -> assert (static_handlers = []); - let k = layout_exp arg in - Matching.for_function ~scopes layout e.exp_loc - None (transl_exp ~scopes arg, k) val_cases partial + let arg_layout = layout_exp arg_sort arg in + Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout + e.exp_loc None (transl_exp ~scopes arg_sort arg) val_cases partial | arg, _ :: _ -> let val_id = Typecore.name_pattern "val" (List.map fst val_cases) in - let k = layout_exp arg in - static_catch [transl_exp ~scopes arg] [val_id, k] - (Matching.for_function ~scopes layout e.exp_loc - None (Lvar val_id, k) val_cases partial) + let arg_layout = layout_exp arg_sort arg in + static_catch [transl_exp ~scopes arg_sort arg] [val_id, arg_layout] + (Matching.for_function ~scopes ~arg_sort ~arg_layout ~return_layout + e.exp_loc None (Lvar val_id) val_cases partial) in List.fold_left (fun body (static_exception_id, val_ids, handler) -> - Lstaticcatch (body, (static_exception_id, val_ids), handler, layout) + Lstaticcatch (body, (static_exception_id, val_ids), handler, return_layout) ) classic static_handlers -and transl_letop ~scopes loc env let_ ands param case partial warnings = - (* CR layouts: The typechecker is currently enforcing that everything here has - layout value, but we might want to relax that when we allow non-value - function args and returns, and then this code would need to be - revisited. *) +and transl_letop ~scopes loc env let_ ands param param_sort case case_sort + partial warnings = let rec loop prev_layout prev_lam = function | [] -> prev_lam | and_ :: rest -> @@ -1651,10 +1667,11 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = transl_ident (of_location ~scopes and_.bop_op_name.loc) env and_.bop_op_type and_.bop_op_path and_.bop_op_val Id_value in - let exp = transl_exp ~scopes and_.bop_exp in - let right_layout = layout_exp and_.bop_exp in + let exp = transl_exp ~scopes Sort.for_bop_exp and_.bop_exp in + let right_layout = layout_exp Sort.for_bop_exp and_.bop_exp in let result_layout = - function2_return_layout env and_.bop_loc and_.bop_op_type + function2_return_layout env and_.bop_loc and_.bop_op_return_sort + and_.bop_op_type in let lam = bind_with_layout Strict (right_id, right_layout) exp @@ -1678,7 +1695,8 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = let_.bop_op_type let_.bop_op_path let_.bop_op_val Id_value in let exp = - loop (layout_exp let_.bop_exp) (transl_exp ~scopes let_.bop_exp) ands + loop (layout_exp Sort.for_bop_exp let_.bop_exp) + (transl_exp ~scopes Sort.for_bop_exp let_.bop_exp) ands in let func = let arg_layout = @@ -1691,21 +1709,16 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = | None -> Misc.fatal_error "Translcore.transl_letop: letop should have at least two arguments" - | Some (lhs, _) -> - match Typeopt.is_function_type env lhs with - | None -> - Misc.fatal_error - "Translcore.transl_letop: letop second argument should be a function" - | Some (arg_type, _) -> - Typeopt.layout env loc arg_type + | Some (lhs, _) -> Typeopt.function_arg_layout env loc param_sort lhs in - let return_layout = layout_exp case.c_rhs in + let return_layout = layout_exp case_sort case.c_rhs in let curry = More_args { partial_mode = Alloc_mode.global } in let (kind, params, return, _region), body = event_function ~scopes case.c_rhs (function repr -> - transl_curried_function ~scopes case.c_rhs.exp_loc return_layout - repr ~region:true ~curry partial warnings param arg_layout [case]) + transl_curried_function ~scopes ~arg_sort:param_sort ~arg_layout + ~return_sort:case_sort ~return_layout case.c_rhs.exp_loc repr + ~region:true ~curry partial warnings param [case]) in let attr = default_function_attribute in let loc = of_location ~scopes case.c_rhs.exp_loc in @@ -1717,7 +1730,9 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = ap_loc = of_location ~scopes loc; ap_func = op; ap_args=[exp; func]; - ap_result_layout=function2_return_layout env let_.bop_loc let_.bop_op_type; + ap_result_layout= + function2_return_layout env let_.bop_loc let_.bop_op_return_sort + let_.bop_op_type; ap_region_close=Rc_normal; ap_mode=alloc_heap; ap_tailcall = Default_tailcall; @@ -1729,14 +1744,15 @@ and transl_letop ~scopes loc env let_ ands param case partial warnings = (* Wrapper for class/module compilation, that can only return global values *) -let transl_exp ~scopes exp = - maybe_region_exp exp (transl_exp ~scopes exp) +let transl_exp ~scopes sort exp = + maybe_region_exp sort exp (transl_exp ~scopes sort exp) -let transl_let ~scopes ?in_structure rec_flag pat_expr_list = - transl_let ~scopes ~add_regions:true ?in_structure rec_flag pat_expr_list +let transl_let ~scopes ~return_layout ?in_structure rec_flag pat_expr_list = + transl_let ~scopes ~return_layout ~add_regions:true ?in_structure rec_flag + pat_expr_list -let transl_scoped_exp ~scopes exp = - maybe_region_exp exp (transl_scoped_exp ~scopes exp) +let transl_scoped_exp ~scopes sort exp = + maybe_region_exp sort exp (transl_scoped_exp ~scopes sort exp) let transl_apply ~scopes ?tailcall ?inlined ?specialised ?position ?mode ~result_layout fn args loc = @@ -1761,6 +1777,11 @@ let report_error ppf = function "Non-value detected in translation:@ Please report this error to \ the Jane Street compilers team.@ %a" (Layout.Violation.report_with_name ~name:"This expression") err + | Void_sort ty -> + fprintf ppf + "Void detected in translation for type %a:@ Please report this error \ + to the Jane Street compilers team." + Printtyp.type_expr ty let () = Location.register_error_of_exn diff --git a/ocaml/lambda/translcore.mli b/ocaml/lambda/translcore.mli index d78490bdba6..e08849a27a4 100644 --- a/ocaml/lambda/translcore.mli +++ b/ocaml/lambda/translcore.mli @@ -23,10 +23,8 @@ open Debuginfo.Scoped_location val pure_module : module_expr -> let_kind -(* Used for translating Alloc_heap values in classes and modules. [transl_exp] - and [transl_scoped_exp] must be called on expressions whose types have sort - value. *) -val transl_exp: scopes:scopes -> expression -> lambda +(* Used for translating Alloc_heap values in classes and modules. *) +val transl_exp: scopes:scopes -> Layouts.sort -> expression -> lambda val transl_apply: scopes:scopes -> ?tailcall:tailcall_attribute -> ?inlined:inlined_attribute @@ -37,20 +35,21 @@ val transl_apply: scopes:scopes -> lambda -> (arg_label * apply_arg) list -> scoped_location -> lambda -val transl_let: scopes:scopes -> ?in_structure:bool - -> rec_flag -> value_binding list -> layout -> lambda -> lambda +val transl_let: scopes:scopes -> return_layout:layout -> ?in_structure:bool + -> rec_flag -> value_binding list -> lambda -> lambda val transl_extension_constructor: scopes:scopes -> Env.t -> Longident.t option -> extension_constructor -> lambda -val transl_scoped_exp : scopes:scopes -> expression -> lambda +val transl_scoped_exp : scopes:scopes -> Layouts.sort -> expression -> lambda type error = Free_super_var | Unreachable_reached | Bad_probe_layout of Ident.t | Non_value_layout of Layouts.Layout.Violation.t + | Void_sort of Types.type_expr exception Error of Location.t * error diff --git a/ocaml/lambda/translmod.ml b/ocaml/lambda/translmod.ml index ccbcfd1a199..c63d5595181 100644 --- a/ocaml/lambda/translmod.ml +++ b/ocaml/lambda/translmod.ml @@ -261,7 +261,7 @@ let record_primitive = function let preallocate_letrec ~bindings ~body = assert (Clflags.is_flambda2 ()); let caml_update_dummy_prim = - Primitive.simple ~name:"caml_update_dummy" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_update_dummy" ~arity:2 ~alloc:true in let update_dummy var expr = Lprim (Pccall caml_update_dummy_prim, [Lvar var; expr], Loc_unknown) @@ -275,7 +275,8 @@ let preallocate_letrec ~bindings ~body = List.fold_left (fun body (id, _def, size) -> let desc = - Primitive.simple ~name:"caml_alloc_dummy" ~arity:1 ~alloc:true + Primitive.simple_on_values ~name:"caml_alloc_dummy" ~arity:1 + ~alloc:true in let size : lambda = Lconst (Const_base (Const_int size)) in Llet (Strict, Lambda.layout_block, id, @@ -617,7 +618,8 @@ and transl_module ~scopes cc rootpath mexp = | Tmod_constraint(arg, _, _, ccarg) -> transl_module ~scopes (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> - apply_coercion loc Strict cc (Translcore.transl_exp ~scopes arg) + apply_coercion loc Strict cc + (Translcore.transl_exp ~scopes Sort.for_module arg) and transl_struct ~scopes loc fields cc rootpath {str_final_env; str_items; _} = transl_structure ~scopes loc fields cc rootpath str_final_env str_items @@ -684,12 +686,12 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function transl_structure ~scopes loc fields cc rootpath final_env rem in sort_must_not_be_void expr.exp_loc expr.exp_type sort; - Lsequence(transl_exp ~scopes expr, body), size + Lsequence(transl_exp ~scopes sort expr, body), size | Tstr_value(rec_flag, pat_expr_list) -> (* Translate bindings first *) let mk_lam_let = - transl_let ~scopes ~in_structure:true rec_flag pat_expr_list - Lambda.layout_module_field + transl_let ~scopes ~return_layout:Lambda.layout_module_field + ~in_structure:true rec_flag pat_expr_list in let ext_fields = List.rev_append (let_bound_idents pat_expr_list) fields in @@ -1119,14 +1121,14 @@ let transl_store_structure ~scopes glob map prims aliases str = | Tstr_eval (expr, sort, _attrs) -> sort_must_not_be_void expr.exp_loc expr.exp_type sort; Lsequence(Lambda.subst no_env_update subst - (transl_exp ~scopes expr), + (transl_exp ~scopes sort expr), transl_store ~scopes rootpath subst cont rem) | Tstr_value(rec_flag, pat_expr_list) -> let ids = let_bound_idents pat_expr_list in let lam = - transl_let ~scopes ~in_structure:true rec_flag pat_expr_list - Lambda.layout_unit - (store_idents Loc_unknown ids) + transl_let ~scopes ~return_layout:Lambda.layout_unit + ~in_structure:true rec_flag pat_expr_list + (store_idents Loc_unknown ids) in Lsequence(Lambda.subst no_env_update subst lam, transl_store ~scopes rootpath @@ -1516,7 +1518,7 @@ let transl_store_gen ~scopes module_name ({ str_items = str }, restr) topl = assert (size = 0); sort_must_not_be_void expr.exp_loc expr.exp_type sort; Lambda.subst (fun _ _ env -> env) !transl_store_subst - (transl_exp ~scopes expr) + (transl_exp ~scopes sort expr) | str -> transl_store_structure ~scopes module_name map prims aliases str in @@ -1617,15 +1619,15 @@ let transl_toplevel_item ~scopes item = unit. *) Tstr_eval (expr, sort, _) -> sort_must_not_be_void expr.exp_loc expr.exp_type sort; - transl_exp ~scopes expr + transl_exp ~scopes sort expr | Tstr_value(Nonrecursive, - [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) -> - transl_exp ~scopes expr + [{vb_pat = {pat_desc=Tpat_any}; vb_expr = expr; + vb_sort = sort}]) -> + transl_exp ~scopes sort expr | Tstr_value(rec_flag, pat_expr_list) -> let idents = let_bound_idents pat_expr_list in - transl_let ~scopes ~in_structure:true rec_flag pat_expr_list - Lambda.layout_unit - (make_sequence toploop_setvalue_id idents) + transl_let ~scopes ~return_layout:Lambda.layout_unit ~in_structure:true + rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) | Tstr_typext(tyext) -> let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors diff --git a/ocaml/lambda/translobj.ml b/ocaml/lambda/translobj.ml index c04fa8089e1..6f491bbd794 100644 --- a/ocaml/lambda/translobj.ml +++ b/ocaml/lambda/translobj.ml @@ -83,8 +83,9 @@ let reset_labels () = let int n = Lconst (Const_base (Const_int n)) +(* CR layouts v5: To change when we have arrays of other sorts *) let prim_makearray = - Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_make_vect" ~arity:2 ~alloc:true (* Also use it for required globals *) let transl_label_init_general f = diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index c3a87af2a8c..b3dd12b3c92 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -18,6 +18,7 @@ open Asttypes open Primitive open Types +open Layouts open Typedtree open Typeopt open Lambda @@ -121,7 +122,7 @@ let gen_array_set_kind mode = if Config.flat_float_array then Pgenarray_set mode else Paddrarray_set mode let prim_sys_argv = - Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true + Primitive.simple_on_values ~name:"caml_sys_argv" ~arity:1 ~alloc:true let to_alloc_mode ~poly = function | Prim_global, _ -> alloc_heap @@ -572,7 +573,8 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = | Primitive (Pmakeblock(tag, mut, None, mode), arity), fields -> begin let shape = List.map (fun typ -> - Lambda.must_be_value (Typeopt.layout env (to_location loc) typ)) + Lambda.must_be_value (Typeopt.layout env (to_location loc) + Sort.for_block_element typ)) fields in let useful = List.exists (fun knd -> knd <> Pgenval) shape in @@ -606,47 +608,51 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = | _ -> None let caml_equal = - Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_equal" ~arity:2 ~alloc:true let caml_string_equal = - Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_string_equal" ~arity:2 ~alloc:false let caml_bytes_equal = - Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_bytes_equal" ~arity:2 ~alloc:false let caml_notequal = - Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_notequal" ~arity:2 ~alloc:true let caml_string_notequal = - Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_string_notequal" ~arity:2 ~alloc:false let caml_bytes_notequal = - Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false let caml_lessequal = - Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_lessequal" ~arity:2 ~alloc:true let caml_string_lessequal = - Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_string_lessequal" ~arity:2 ~alloc:false let caml_bytes_lessequal = - Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false let caml_lessthan = - Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_lessthan" ~arity:2 ~alloc:true let caml_string_lessthan = - Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_string_lessthan" ~arity:2 ~alloc:false let caml_bytes_lessthan = - Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false let caml_greaterequal = - Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_greaterequal" ~arity:2 ~alloc:true let caml_string_greaterequal = - Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_string_greaterequal" ~arity:2 + ~alloc:false let caml_bytes_greaterequal = - Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_bytes_greaterequal" ~arity:2 + ~alloc:false let caml_greaterthan = - Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_greaterthan" ~arity:2 ~alloc:true let caml_string_greaterthan = - Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false + Primitive.simple_on_values ~name:"caml_string_greaterthan" ~arity:2 + ~alloc:false let caml_bytes_greaterthan = - Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false + Primitive.simple_on_values ~name:"caml_bytes_greaterthan" ~arity:2 + ~alloc:false let caml_compare = - Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true + Primitive.simple_on_values ~name:"caml_compare" ~arity:2 ~alloc:true let caml_string_compare = - Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_string_compare" ~arity:2 ~alloc:false let caml_bytes_compare = - Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_bytes_compare" ~arity:2 ~alloc:false let comparison_primitive comparison comparison_kind = match comparison, comparison_kind with @@ -747,7 +753,8 @@ let lambda_of_loc kind sloc = Lconst (Const_immstring scope_name) let caml_restore_raw_backtrace = - Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false + Primitive.simple_on_values ~name:"caml_restore_raw_backtrace" ~arity:2 + ~alloc:false let try_ids = Hashtbl.create 8 @@ -880,19 +887,27 @@ let transl_primitive loc p env ty ~poly_mode path = | None -> prim | Some prim -> prim in - let rec make_params ty n = - if n <= 0 then [], Typeopt.layout env (to_location loc) ty - else + let rec make_params ty repr_args repr_res = + match repr_args, repr_res with + | [], (_, res_repr) -> + let res_sort = sort_of_native_repr res_repr in + [], Typeopt.layout env (to_location loc) (Sort.of_const res_sort) ty + | ((_, arg_repr) :: repr_args), _ -> match Typeopt.is_function_type env ty with | None -> Misc.fatal_errorf "Primitive %s type does not correspond to arity" (Primitive.byte_name p) | Some (arg_ty, ret_ty) -> - let arg_layout = Typeopt.layout env (to_location loc) arg_ty in - let params, return = make_params ret_ty (n-1) in + let arg_sort = sort_of_native_repr arg_repr in + let arg_layout = + Typeopt.layout env (to_location loc) (Sort.of_const arg_sort) arg_ty + in + let params, return = make_params ret_ty repr_args repr_res in (Ident.create_local "prim", arg_layout) :: params, return in - let params, return = make_params ty p.prim_arity in + let params, return = + make_params ty p.prim_native_repr_args p.prim_native_repr_res + in let args = List.map (fun (id, _) -> Lvar id) params in match params with | [] -> lambda_of_prim p.prim_name prim loc args None diff --git a/ocaml/middle_end/convert_primitives.ml b/ocaml/middle_end/convert_primitives.ml index 7cc2e8a324c..43fab009bb4 100644 --- a/ocaml/middle_end/convert_primitives.ml +++ b/ocaml/middle_end/convert_primitives.ml @@ -152,8 +152,8 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = ~effects:Only_generative_effects ~coeffects:Has_coeffects ~native_name:"caml_obj_dup" - ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr] - ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr)) + ~native_repr_args:[P.Prim_global, P.Same_as_ocaml_repr Layouts.Sort.Value] + ~native_repr_res:(P.Prim_global, P.Same_as_ocaml_repr Layouts.Sort.Value)) | Punbox_float -> Punbox_float | Pbox_float m -> Pbox_float m | Punbox_int bi -> Punbox_int bi diff --git a/ocaml/middle_end/flambda/flambda_to_clambda.ml b/ocaml/middle_end/flambda/flambda_to_clambda.ml index 591e91da625..7a337694c12 100644 --- a/ocaml/middle_end/flambda/flambda_to_clambda.ml +++ b/ocaml/middle_end/flambda/flambda_to_clambda.ml @@ -79,7 +79,7 @@ let check_closure t ulam named : Clambda.ulambda = if not !Clflags.clambda_checks then ulam else let desc = - Primitive.simple ~name:"caml_check_value_is_closure" + Primitive.simple_on_values ~name:"caml_check_value_is_closure" ~arity:2 ~alloc:false in let str = Format.asprintf "%a" Flambda.print_named named in @@ -108,7 +108,7 @@ let check_field t ulam pos named_opt : Clambda.ulambda = if not !Clflags.clambda_checks then ulam else let desc = - Primitive.simple ~name:"caml_check_field_access" + Primitive.simple_on_values ~name:"caml_check_field_access" ~arity:3 ~alloc:false in let str = diff --git a/ocaml/ocamldoc/odoc_ast.ml b/ocaml/ocamldoc/odoc_ast.ml index b8a745df79a..02018ede594 100644 --- a/ocaml/ocamldoc/odoc_ast.ml +++ b/ocaml/ocamldoc/odoc_ast.ml @@ -784,10 +784,12 @@ module Analyser = [] arg_list in - let param_types = List.map (fun e -> e.Typedtree.exp_type) param_exps in + let param_types = + List.map (fun (e, _) -> e.Typedtree.exp_type) param_exps + in let params_code = List.map - (fun e -> get_string_of_file + (fun (e, _) -> get_string_of_file e.exp_loc.Location.loc_start.Lexing.pos_cnum e.exp_loc.Location.loc_end.Lexing.pos_cnum) param_exps diff --git a/ocaml/otherlibs/dynlink/Makefile b/ocaml/otherlibs/dynlink/Makefile index 22baeaaf1c3..800a34b4652 100644 --- a/ocaml/otherlibs/dynlink/Makefile +++ b/ocaml/otherlibs/dynlink/Makefile @@ -107,9 +107,9 @@ COMPILERLIBS_SOURCES=\ parsing/attr_helper.ml \ parsing/pprintast.ml \ typing/path.ml \ - typing/primitive.ml \ typing/shape.ml \ typing/layouts.ml \ + typing/primitive.ml \ typing/types.ml \ typing/btype.ml \ typing/subst.ml \ diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index f767d94ec18..9f36d60d96b 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -52,9 +52,9 @@ builtin_attributes ident path - primitive shape layouts + primitive types btype lazy_backtrack @@ -136,9 +136,9 @@ (copy_files ../../parsing/builtin_attributes.ml) (copy_files ../../typing/ident.ml) (copy_files ../../typing/path.ml) +(copy_files ../../typing/layouts.ml) (copy_files ../../typing/primitive.ml) (copy_files ../../typing/shape.ml) -(copy_files ../../typing/layouts.ml) (copy_files ../../typing/types.ml) (copy_files ../../typing/btype.ml) (copy_files ../../typing/subst.ml) @@ -193,9 +193,9 @@ (copy_files ../../parsing/builtin_attributes.mli) (copy_files ../../typing/ident.mli) (copy_files ../../typing/path.mli) +(copy_files ../../typing/layouts.mli) (copy_files ../../typing/primitive.mli) (copy_files ../../typing/shape.mli) -(copy_files ../../typing/layouts.mli) (copy_files ../../typing/types.mli) (copy_files ../../typing/btype.mli) (copy_files ../../typing/subst.mli) diff --git a/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_a.ml b/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_a.ml new file mode 100644 index 00000000000..f18979e3c71 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_a.ml @@ -0,0 +1,3 @@ + +type t = Mk of int + diff --git a/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_arg.ml b/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_arg.ml new file mode 100644 index 00000000000..98f31cdf84b --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_arg.ml @@ -0,0 +1,94 @@ +(* TEST + +readonly_files = "function_a.ml function_b.ml" +* setup-ocamlc.byte-build-env +** ocamlc.byte +module = "function_a.ml" +*** ocamlc.byte +module = "function_b.ml" +**** script +script = "rm -f function_a.cmi" +***** expect +*) + +#directory "ocamlc.byte";; +#load "function_b.cmo";; + +(* This tests that sorts are correctly extracted from function types, + even in the presence of a missing cmi file. *) + +let f0 (g : Function_b.fun_t) = g ~arg1:(assert false) + +[%%expect{| +Line 1, characters 40-54: +1 | let f0 (g : Function_b.fun_t) = g ~arg1:(assert false) + ^^^^^^^^^^^^^^ +Error: Function arguments and returns must be representable. + Function_a.t has an unknown layout, which might not be representable. + No .cmi file found containing Function_a.t. + Hint: Adding "function_a" to your dependencies might help. +|}] + +let f1 (g : Function_b.fun_t) = g () + +[%%expect{| +Line 1, characters 34-36: +1 | let f1 (g : Function_b.fun_t) = g () + ^^ +Error: Function arguments and returns must be representable. + Function_a.t has an unknown layout, which might not be representable. + No .cmi file found containing Function_a.t. + Hint: Adding "function_a" to your dependencies might help. +|}] + +let f2 : Function_b.fun_t = fun ~arg1:_ ~arg2 () -> arg2 + +[%%expect{| +Line 1, characters 28-56: +1 | let f2 : Function_b.fun_t = fun ~arg1:_ ~arg2 () -> arg2 + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Function arguments and returns must be representable. + Function_a.t has an unknown layout, which might not be representable. + No .cmi file found containing Function_a.t. + Hint: Adding "function_a" to your dependencies might help. +|}] + +let f3 : Function_b.return_t = fun () -> assert false + +[%%expect{| +Line 1, characters 31-53: +1 | let f3 : Function_b.return_t = fun () -> assert false + ^^^^^^^^^^^^^^^^^^^^^^ +Error: Function arguments and returns must be representable. + Function_a.t has an unknown layout, which might not be representable. + No .cmi file found containing Function_a.t. + Hint: Adding "function_a" to your dependencies might help. +|}] + +let f4 (_ : Function_b.take_t) = () +let x1 = f4 Function_b.f_opt + +[%%expect{| +val f4 : Function_b.take_t -> unit = +Line 2, characters 12-28: +2 | let x1 = f4 Function_b.f_opt + ^^^^^^^^^^^^^^^^ +Error: Function arguments and returns must be representable. + Function_a.t has an unknown layout, which might not be representable. + No .cmi file found containing Function_a.t. + Hint: Adding "function_a" to your dependencies might help. +|}] + +let f5 (_ : Function_b.return_t) = () +let x2 = f5 Function_b.f_opt_2 + +[%%expect{| +val f5 : Function_b.return_t -> unit = +Line 2, characters 12-30: +2 | let x2 = f5 Function_b.f_opt_2 + ^^^^^^^^^^^^^^^^^^ +Error: Function arguments and returns must be representable. + Function_a.t has an unknown layout, which might not be representable. + No .cmi file found containing Function_a.t. + Hint: Adding "function_a" to your dependencies might help. +|}] diff --git a/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_b.ml b/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_b.ml new file mode 100644 index 00000000000..5afc4484a19 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-missing-cmi/function_b.ml @@ -0,0 +1,9 @@ + +type fun_t = arg1:Function_a.t -> arg2:Function_a.t -> unit -> Function_a.t + +type take_t = Function_a.t -> unit +type return_t = unit -> Function_a.t + +let f_opt : ?opt:int -> Function_a.t -> unit = fun ?opt _ -> () +let f_opt_2 : ?opt:int -> unit -> Function_a.t = fun ?opt _ -> assert false + diff --git a/ocaml/testsuite/tests/typing-layouts/basics.ml b/ocaml/testsuite/tests/typing-layouts/basics.ml index f5233e4f582..708922d3804 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics.ml @@ -311,3 +311,10 @@ Error: Layout void is used here, but the appropriate layouts extension is not en (* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value sort. Bring back here when we have one enabled by default. *) + +(******************************************************) +(* Test 33: Externals must have representable types *) + +(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a + non-representable layout. Bring it back here when we can mention [t_any] in + [-extension layouts]. *) diff --git a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml index dd15839a54a..d0850d59575 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml @@ -185,9 +185,8 @@ end;; Line 2, characters 8-44: 2 | let g z = X.f { vr_void = z; vr_int = 42 } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}];; (**************************************) @@ -1095,12 +1094,11 @@ let f19 () = let _y = (x :> t_void) in ();; [%%expect{| -Line 3, characters 12-13: +Line 3, characters 6-8: 3 | let _y = (x :> t_void) in - ^ -Error: Non-value detected in translation: + ^^ +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - This expression has layout void, which is not a sublayout of value. |}];; (********************************************) @@ -1113,12 +1111,11 @@ let f20 () = in ();; [%%expect{| -Lines 4-5, characters 4-5: -4 | ....let module M = struct end in -5 | x -Error: Non-value detected in translation: +Line 3, characters 6-8: +3 | let _y = + ^^ +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - This expression has layout void, which is not a sublayout of value. |}];; (**********************************) @@ -1134,12 +1131,11 @@ let f21 () = ();; [%%expect{| module type M21 = sig end -Lines 6-7, characters 4-5: -6 | ....let (module M) = (module struct end : M21) in +Line 7, characters 4-5: 7 | x -Error: Non-value detected in translation: + ^ +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - This expression has layout void, which is not a sublayout of value. |}];; (***************************************************************) @@ -1209,9 +1205,9 @@ type 'a t2_void [@@void] Line 3, characters 6-30: 3 | let f (x : 'a. 'a t2_void) = x ^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type + 'a. 'a t2_void. Please report this error to the Jane Street compilers team. - 'a. 'a t2_void has layout void, which is not a sublayout of value. |}] (**************************************************) @@ -1239,9 +1235,8 @@ let g f (x : t_void) : t_void = f x Line 1, characters 8-35: 1 | let g f (x : t_void) : t_void = f x ^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] (******************************************) @@ -1253,9 +1248,8 @@ let rec f : _ -> _ = fun (x : t_void) -> x Line 1, characters 21-42: 1 | let rec f : _ -> _ = fun (x : t_void) -> x ^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] (**********************************************) @@ -1276,9 +1270,8 @@ and q () = Line 1, characters 17-36: 1 | let rec ( let* ) (x : t_void) f = () ^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] let rec ( let* ) x (f : t_void -> _) = () @@ -1291,9 +1284,8 @@ and q () = Lines 4-5, characters 2-4: 4 | ..let* x = assert false in 5 | () -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] let rec ( let* ) x (f : _ -> t_void) = () @@ -1306,9 +1298,8 @@ and q () = Line 5, characters 2-14: 5 | assert false ^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] let rec ( let* ) x f : t_void = assert false @@ -1321,9 +1312,8 @@ and q () = Line 1, characters 19-44: 1 | let rec ( let* ) x f : t_void = assert false ^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] let rec ( let* ) x f = () @@ -1338,9 +1328,8 @@ and q () = Line 2, characters 16-34: 2 | and ( and* ) x1 (x2 : t_void) = () ^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] let rec ( let* ) x f = () @@ -1355,9 +1344,8 @@ and q () = Line 2, characters 13-34: 2 | and ( and* ) (x1 : t_void) x2 = () ^^^^^^^^^^^^^^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] let rec ( let* ) x f = () @@ -1372,9 +1360,8 @@ and q () = Line 1, characters 17-25: 1 | let rec ( let* ) x f = () ^^^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type t_void. Please report this error to the Jane Street compilers team. - t_void has layout void, which is not a sublayout of value. |}] (* CR layouts v5: when we allow non-values in tuples, this next one should @@ -1458,6 +1445,7 @@ Line 1, characters 41-43: Error: This type ('a : value) should be an instance of type ('a0 : void) 'a has layout void, which does not overlap with value. |}] + (* CR layouts bug: this should be accepted (or maybe we should reject the type definition if we're not allowing `void` things in structures). This bug is a goof at the top of Typecore.build_or_pat; @@ -1476,3 +1464,16 @@ Error: This expression has type t_void but an expression was expected of type ('a : value) t_void has layout void, which is not a sublayout of value. |}] + +(******************************************************) +(* Test 33: Externals must have representable types *) +external foo33 : t_any = "foo33";; + +[%%expect{| +Line 1, characters 17-22: +1 | external foo33 : t_any = "foo33";; + ^^^^^ +Error: This type signature for foo33 is not a value type. + foo33 has layout any, which is not a sublayout of value. +|}] + diff --git a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml index 636fa63575a..cc789c785ba 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_beta.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_beta.ml @@ -517,3 +517,10 @@ Error: Layout void is used here, but the appropriate layouts extension is not en (* CR layouts: This test moves to [basics_alpha.ml] as it needs a non-value sort. Bring back here when we have one. *) + +(******************************************************) +(* Test 33: Externals must have representable types *) + +(* CR layouts v2: This test moved to [basics_alpha.ml] as it needs a + non-representable layout. Bring it back here when we can mention [t_any] in + [-extension layouts_beta]. *) diff --git a/ocaml/testsuite/tests/typing-layouts/modules_alpha.ml b/ocaml/testsuite/tests/typing-layouts/modules_alpha.ml index e464b3e4e67..b4429deeee8 100644 --- a/ocaml/testsuite/tests/typing-layouts/modules_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/modules_alpha.ml @@ -162,9 +162,8 @@ end;; Line 4, characters 13-19: 4 | let create _ = () ^^^^^^ -Error: Non-value detected in [value_kind]. +Error: Non-value detected in [Typeopt.layout] as sort for type 'a. Please report this error to the Jane Street compilers team. - 'a has layout void, which is not a sublayout of value. |}];; module rec Foo3 : sig diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 54781d1c2d3..10cf12857c1 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -3771,9 +3771,19 @@ type filter_arrow_failure = ; expected_type : type_expr } | Not_a_function + | Layout_error of type_expr * Layout.Violation.t exception Filter_arrow_failed of filter_arrow_failure +type filtered_arrow = + { ty_arg : type_expr; + arg_mode : alloc_mode; + arg_sort : sort; + ty_ret : type_expr; + ret_mode : alloc_mode; + ret_sort : sort + } + let filter_arrow env t l ~force_tpoly = let function_type level = (* CR layouts v3: This is one of two primary places where we are restricting @@ -3784,12 +3794,14 @@ let filter_arrow env t l ~force_tpoly = allow both to be any. Separately, the relevant checks on function arguments should happen when functions are constructed, not their types. *) - let l1 = Layout.of_new_sort_var ~why:Function_argument in - let l2 = Layout.of_new_sort_var ~why:Function_result in - let t1 = + let arg_sort = Sort.new_var () in + let l_arg = Layout.of_sort ~why:Function_argument arg_sort in + let ret_sort = Sort.new_var () in + let l_res = Layout.of_sort ~why:Function_result ret_sort in + let ty_arg = if not force_tpoly then begin assert (not (is_optional l)); - newvar2 level l1 + newvar2 level l_arg end else begin let t1 = if is_optional l then @@ -3800,21 +3812,23 @@ let filter_arrow env t l ~force_tpoly = [newvar2 level (Layout.value ~why:Type_argument)], ref Mnil)) else - newvar2 level l1 + newvar2 level l_arg in newty2 ~level (Tpoly(t1, [])) end in - let t2 = newvar2 level l2 in - let marg = Alloc_mode.newvar () in - let mret = Alloc_mode.newvar () in - let t' = newty2 ~level (Tarrow ((l,marg,mret), t1, t2, commu_ok)) in - t', marg, t1, mret, t2 + let ty_ret = newvar2 level l_res in + let arg_mode = Alloc_mode.newvar () in + let ret_mode = Alloc_mode.newvar () in + let t' = + newty2 ~level (Tarrow ((l, arg_mode, ret_mode), ty_arg, ty_ret, commu_ok)) + in + t', { ty_arg; arg_mode; arg_sort; ty_ret; ret_mode; ret_sort } in let t = try expand_head_trace env t with Unify_trace trace -> - let t', _, _, _, _ = function_type (get_level t) in + let t', _ = function_type (get_level t) in raise (Filter_arrow_failed (Unification_error (expand_to_unification_error @@ -3823,13 +3837,27 @@ let filter_arrow env t l ~force_tpoly = in match get_desc t with Tvar { layout } -> - let t', marg, t1, mret, t2 = function_type (get_level t) in + let t', arrow_desc = function_type (get_level t) in link_type t t'; constrain_type_layout_exn env Unify t' layout; - (marg, t1, mret, t2) - | Tarrow((l', marg, mret), t1, t2, _) -> + arrow_desc + | Tarrow((l', arg_mode, ret_mode), ty_arg, ty_ret, _) -> if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') - then (marg, t1, mret, t2) + then + (* CR layouts v2.5: When we move the restrictions on argument from + arrows to functions, this function doesn't need to return a sort and + these calls to [type_sort] can move. We could eliminate them + entirely by storing sorts on [TArrow], but that seems incompatible + with the future plan to shift the layout requirements from the types + to the terms. *) + let type_sort ~why ty = + match type_sort ~why env ty with + | Ok sort -> sort + | Error err -> raise (Filter_arrow_failed (Layout_error (ty, err))) + in + let arg_sort = type_sort ~why:Function_argument ty_arg in + let ret_sort = type_sort ~why:Function_result ty_ret in + { ty_arg; arg_mode; arg_sort; ty_ret; ret_mode; ret_sort } else raise (Filter_arrow_failed (Label_mismatch { got = l; expected = l'; expected_type = t })) @@ -3849,10 +3877,10 @@ exception Filter_arrow_mono_failed let filter_arrow_mono env t l = match filter_arrow env t l ~force_tpoly:true with | exception Filter_arrow_failed _ -> raise Filter_arrow_mono_failed - | (marg, t1, mret, t2) -> - match filter_mono t1 with + | {ty_arg; _} as farr -> + match filter_mono ty_arg with | exception Filter_mono_failed -> raise Filter_arrow_mono_failed - | t1 -> (marg, t1, mret, t2) + | ty_arg -> { farr with ty_arg } type filter_method_failure = | Unification_error of unification_error diff --git a/ocaml/typing/ctype.mli b/ocaml/typing/ctype.mli index b12ec0d4e3f..60846b8440e 100644 --- a/ocaml/typing/ctype.mli +++ b/ocaml/typing/ctype.mli @@ -245,8 +245,17 @@ val unify_delaying_layout_checks : typedecl before well-foundedness checks have made layout checking safe. *) +type filtered_arrow = + { ty_arg : type_expr; + arg_mode : alloc_mode; + arg_sort : sort; + ty_ret : type_expr; + ret_mode : alloc_mode; + ret_sort : sort + } + val filter_arrow: Env.t -> type_expr -> arg_label -> force_tpoly:bool -> - alloc_mode * type_expr * alloc_mode * type_expr + filtered_arrow (* A special case of unification (with l:'a -> 'b). If [force_poly] is false then the usual invariant that the argument type be a [Tpoly] node is not enforced. Raises @@ -255,8 +264,7 @@ val filter_mono: type_expr -> type_expr (* A special case of unification (with Tpoly('a, [])). Can only be called on [Tpoly] nodes. Raises [Filter_mono_failed] instead of [Unify] *) -val filter_arrow_mono: Env.t -> type_expr -> arg_label -> - alloc_mode * type_expr * alloc_mode * type_expr +val filter_arrow_mono: Env.t -> type_expr -> arg_label -> filtered_arrow (* A special case of unification. Composition of [filter_arrow] with [filter_mono] on the argument type. Raises [Filter_arrow_mono_failed] instead of [Unify] *) @@ -297,6 +305,7 @@ type filter_arrow_failure = ; expected_type : type_expr } | Not_a_function + | Layout_error of type_expr * Layout.Violation.t exception Filter_arrow_failed of filter_arrow_failure diff --git a/ocaml/typing/includecore.ml b/ocaml/typing/includecore.ml index f8377cf20fd..6a1b6cee289 100644 --- a/ocaml/typing/includecore.ml +++ b/ocaml/typing/includecore.ml @@ -76,8 +76,8 @@ let primitive_descriptions pd1 pd2 = else if not (String.equal pd1.prim_native_name pd2.prim_native_name) then Some Native_name else if not - (Primitive.equal_native_repr - (snd pd1.prim_native_repr_res) (snd pd2.prim_native_repr_res)) then + (match pd1.prim_native_repr_res, pd2.prim_native_repr_res with + | (_, nr1), (_, nr2) -> Primitive.equal_native_repr nr1 nr2) then Some Result_repr else native_repr_args pd1.prim_native_repr_args pd2.prim_native_repr_args diff --git a/ocaml/typing/layouts.ml b/ocaml/typing/layouts.ml index 49fcbc62fd1..aaf2af9ad8b 100644 --- a/ocaml/typing/layouts.ml +++ b/ocaml/typing/layouts.ml @@ -151,6 +151,13 @@ module Sort = struct | Unequal -> false | Equal_mutated_first | Equal_mutated_second | Equal_no_mutation -> true + let equal_const c1 c2 = + match c1, c2 with + | Void, Void + | Value, Value -> true + | Void, Value + | Value, Void -> false + let rec is_void_defaulting = function | Const Void -> true | Var v -> begin match !v with @@ -189,6 +196,28 @@ module Sort = struct and var ppf v = fprintf ppf "{ contents = %a }" opt_t (!v) end + + let for_function = value + let for_predef_value = value + let for_block_element = value + let for_probe_body = value + let for_poly_variant = value + let for_record = value + let for_record_field = value + let for_constructor_arg = value + let for_object = value + let for_lazy_body = value + let for_tuple_element = value + let for_instance_var = value + let for_bop_exp = value + let for_class_arg = value + let for_method = value + let for_initializer = value + let for_module = value + let for_tuple = value + let for_array_get_result = value + let for_array_element = value + let for_list_element = value end type sort = Sort.t @@ -208,6 +237,9 @@ module Layout = struct | Function_result | Structure_item_expression | V1_safety_check + | External_argument + | External_result + | Statement type value_creation_reason = | Class_let_binding @@ -568,6 +600,12 @@ module Layout = struct fprintf ppf "used in an expression in a structure" | V1_safety_check -> fprintf ppf "part of the v1 safety check" + | External_argument -> + fprintf ppf "used as an argument in an external declaration" + | External_result -> + fprintf ppf "used as the result of an external declaration" + | Statement -> + fprintf ppf "used as a statement" let format_annotation_context ppf : annotation_context -> unit = function | Type_declaration p -> @@ -998,6 +1036,12 @@ module Layout = struct fprintf ppf "Structure_item_expression" | V1_safety_check -> fprintf ppf "V1_safety_check" + | External_argument -> + fprintf ppf "External_argument" + | External_result -> + fprintf ppf "External_result" + | Statement -> + fprintf ppf "Statement" let annotation_context ppf : annotation_context -> unit = function | Type_declaration p -> diff --git a/ocaml/typing/layouts.mli b/ocaml/typing/layouts.mli index 796f6b0aa72..869b2296dd7 100644 --- a/ocaml/typing/layouts.mli +++ b/ocaml/typing/layouts.mli @@ -50,6 +50,8 @@ module Sort : sig equal, if possible *) val equate : t -> t -> bool + val equal_const : const -> const -> bool + val format : Format.formatter -> t -> unit (** Defaults any variables to value; leaves other sorts alone *) @@ -59,10 +61,47 @@ module Sort : sig variable is unfilled. *) val is_void_defaulting : t -> bool + (** [get_default_value] extracts the sort as a `const`. If it's a variable, + it is set to [value] first. *) + val get_default_value : t -> const + module Debug_printers : sig val t : Format.formatter -> t -> unit val var : Format.formatter -> var -> unit end + + (* CR layouts: These are sorts for the types of ocaml expressions that are + currently required to be values, but for which we expect to relax that + restriction in versions 2 and beyond. Naming them makes it easy to find + where in the translation to lambda they are assume to be value. *) + (* CR layouts: add similarly named layouts and use those names everywhere (not + just the translation to lambda) rather than writing specific layouts and + sorts in the code. *) + val for_class_arg : t + val for_instance_var : t + val for_bop_exp : t + val for_lazy_body : t + val for_tuple_element : t + val for_record : t + val for_record_field : t + val for_constructor_arg : t + val for_block_element : t + val for_array_get_result : t + val for_array_element : t + val for_list_element : t + + (** These are sorts for the types of ocaml expressions that we expect will + always be "value". These names are used in the translation to lambda to + make the code clearer. *) + val for_function : t + val for_probe_body : t + val for_poly_variant : t + val for_object : t + val for_initializer : t + val for_method : t + val for_module : t + val for_predef_value : t (* Predefined value types, e.g. int and string *) + val for_tuple : t end type sort = Sort.t @@ -101,6 +140,9 @@ module Layout : sig | Function_result | Structure_item_expression | V1_safety_check + | External_argument + | External_result + | Statement type annotation_context = | Type_declaration of Path.t diff --git a/ocaml/typing/primitive.ml b/ocaml/typing/primitive.ml index d6de7b654dd..34804aaee3b 100644 --- a/ocaml/typing/primitive.ml +++ b/ocaml/typing/primitive.ml @@ -17,11 +17,12 @@ open Misc open Parsetree +open Layouts type boxed_integer = Pnativeint | Pint32 | Pint64 type native_repr = - | Same_as_ocaml_repr + | Same_as_ocaml_repr of Layouts.Sort.const | Unboxed_float | Unboxed_integer of boxed_integer | Untagged_int @@ -55,20 +56,20 @@ type error = exception Error of Location.t * error let is_ocaml_repr = function - | _, Same_as_ocaml_repr -> true + | _, Same_as_ocaml_repr _ -> true | _, Unboxed_float | _, Unboxed_integer _ | _, Untagged_int -> false let is_unboxed = function - | _, Same_as_ocaml_repr + | _, Same_as_ocaml_repr _ | _, Untagged_int -> false | _, Unboxed_float | _, Unboxed_integer _ -> true let is_untagged = function | _, Untagged_int -> true - | _, Same_as_ocaml_repr + | _, Same_as_ocaml_repr _ | _, Unboxed_float | _, Unboxed_integer _ -> false @@ -78,7 +79,7 @@ let rec make_native_repr_args arity x = else x :: make_native_repr_args (arity - 1) x -let simple ~name ~arity ~alloc = +let simple_on_values ~name ~arity ~alloc = {prim_name = name; prim_arity = arity; prim_alloc = alloc; @@ -87,8 +88,8 @@ let simple ~name ~arity ~alloc = prim_coeffects = Has_coeffects; prim_native_name = ""; prim_native_repr_args = - make_native_repr_args arity (Prim_global, Same_as_ocaml_repr); - prim_native_repr_res = (Prim_global, Same_as_ocaml_repr) } + make_native_repr_args arity (Prim_global, Same_as_ocaml_repr Sort.Value); + prim_native_repr_res = (Prim_global, Same_as_ocaml_repr Sort.Value) } let make ~name ~alloc ~c_builtin ~effects ~coeffects ~native_name ~native_repr_args ~native_repr_res = @@ -254,7 +255,7 @@ let print p osig_val_decl = | Prim_poly -> [oattr_local_opt]) @ (match repr with - | Same_as_ocaml_repr -> [] + | Same_as_ocaml_repr _ -> [] | Unboxed_float | Unboxed_integer _ -> if all_unboxed then [] else [oattr_unboxed] | Untagged_int -> if all_untagged then [] else [oattr_untagged]) @@ -287,18 +288,18 @@ let equal_boxed_integer bi1 bi2 = let equal_native_repr nr1 nr2 = match nr1, nr2 with - | Same_as_ocaml_repr, Same_as_ocaml_repr -> true - | Same_as_ocaml_repr, + | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> Sort.equal_const s1 s2 + | Same_as_ocaml_repr _, (Unboxed_float | Unboxed_integer _ | Untagged_int) -> false | Unboxed_float, Unboxed_float -> true | Unboxed_float, - (Same_as_ocaml_repr | Unboxed_integer _ | Untagged_int) -> false + (Same_as_ocaml_repr _ | Unboxed_integer _ | Untagged_int) -> false | Unboxed_integer bi1, Unboxed_integer bi2 -> equal_boxed_integer bi1 bi2 | Unboxed_integer _, - (Same_as_ocaml_repr | Unboxed_float | Untagged_int) -> false + (Same_as_ocaml_repr _ | Unboxed_float | Untagged_int) -> false | Untagged_int, Untagged_int -> true | Untagged_int, - (Same_as_ocaml_repr | Unboxed_float | Unboxed_integer _) -> false + (Same_as_ocaml_repr _ | Unboxed_float | Unboxed_integer _) -> false let equal_effects ef1 ef2 = match ef1, ef2 with @@ -320,6 +321,10 @@ let native_name_is_external p = let nat_name = native_name p in nat_name <> "" && nat_name.[0] <> '%' +let sort_of_native_repr = function + | Same_as_ocaml_repr s -> s + | (Unboxed_float | Unboxed_integer _ | Untagged_int) -> Sort.Value + let report_error ppf err = match err with | Old_style_float_with_native_repr_attribute -> diff --git a/ocaml/typing/primitive.mli b/ocaml/typing/primitive.mli index de496fc3711..a52e550c5fe 100644 --- a/ocaml/typing/primitive.mli +++ b/ocaml/typing/primitive.mli @@ -20,7 +20,7 @@ type boxed_integer = Pnativeint | Pint32 | Pint64 (* Representation of arguments/result for the native code version of a primitive *) type native_repr = - | Same_as_ocaml_repr + | Same_as_ocaml_repr of Layouts.Sort.const | Unboxed_float | Unboxed_integer of boxed_integer | Untagged_int @@ -56,7 +56,7 @@ type description = private (* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) -val simple +val simple_on_values : name:string -> arity:int -> alloc:bool @@ -69,14 +69,14 @@ val make -> effects:effects -> coeffects:coeffects -> native_name:string - -> native_repr_args: (mode*native_repr) list - -> native_repr_res: mode*native_repr + -> native_repr_args: (mode * native_repr) list + -> native_repr_res: mode * native_repr -> description val parse_declaration : Parsetree.value_description - -> native_repr_args:(mode*native_repr) list - -> native_repr_res:(mode*native_repr) + -> native_repr_args:(mode * native_repr) list + -> native_repr_res:(mode * native_repr) -> description val print @@ -97,6 +97,10 @@ val equal_coeffects : coeffects -> coeffects -> bool compiler itself. *) val native_name_is_external : description -> bool +(** [sort_of_native_repr] returns the sort expected during typechecking (which + may be different than the sort used in the external interface). *) +val sort_of_native_repr : native_repr -> Layouts.Sort.const + type error = | Old_style_float_with_native_repr_attribute | Old_style_noalloc_with_noalloc_attribute diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index 5a882d80b04..d16fc148a18 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -452,10 +452,10 @@ and expression i ppf x = expression i ppf e1; expression i ppf e2; option i expression ppf eo; - | Texp_sequence (e1, l, e2) -> + | Texp_sequence (e1, s, e2) -> line i ppf "Texp_sequence\n"; expression i ppf e1; - line i ppf "%a\n" Layouts.Layout.format l; + line i ppf "%a\n" Layouts.Sort.format s; expression i ppf e2; | Texp_while {wh_cond; wh_body} -> line i ppf "Texp_while\n"; @@ -1061,7 +1061,7 @@ and record_field i ppf = function and label_x_apply_arg i ppf (l, e) = line i ppf "\n"; arg_label (i+1) ppf l; - (match e with Omitted _ -> () | Arg e -> expression (i+1) ppf e) + (match e with Omitted _ -> () | Arg (e, _) -> expression (i+1) ppf e) and ident_x_expression_def i ppf (l, e) = line i ppf " \"%a\"\n" fmt_ident l; diff --git a/ocaml/typing/rec_check.ml b/ocaml/typing/rec_check.ml index ba061870720..7b429cd495d 100644 --- a/ocaml/typing/rec_check.ml +++ b/ocaml/typing/rec_check.ml @@ -583,7 +583,7 @@ let rec expression : Typedtree.expression -> term_judg = | Texp_instvar (self_path, pth, _inst_var) -> join [path self_path << Dereference; path pth] | Texp_apply - ({exp_desc = Texp_ident (_, _, vd, Id_prim _)}, [_, Arg arg], _, _) + ({exp_desc = Texp_ident (_, _, vd, Id_prim _)}, [_, Arg (arg, _)], _, _) when is_ref vd -> (* G |- e: m[Guard] @@ -595,7 +595,7 @@ let rec expression : Typedtree.expression -> term_judg = let arg (_, arg) = match arg with | Omitted _ -> empty - | Arg e -> expression e + | Arg (e, _) -> expression e in let app_mode = if List.exists is_abstracted_arg args then (* see the comment on Texp_apply in typedtree.mli; @@ -1071,7 +1071,7 @@ and class_expr : Typedtree.class_expr -> term_judg = let arg (_, arg) = match arg with | Omitted _ -> empty - | Arg e -> expression e + | Arg (e, _) -> expression e in join [ class_expr ce << Dereference; diff --git a/ocaml/typing/tast_iterator.ml b/ocaml/typing/tast_iterator.ml index 801c571de81..b54dd1b4601 100644 --- a/ocaml/typing/tast_iterator.ml +++ b/ocaml/typing/tast_iterator.ml @@ -211,7 +211,7 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = | Texp_apply (exp, list, _, _) -> sub.expr sub exp; List.iter (function - | (_, Arg exp) -> sub.expr sub exp + | (_, Arg (exp, _)) -> sub.expr sub exp | (_, Omitted _) -> ()) list | Texp_match (exp, _, cases, _) -> @@ -416,8 +416,8 @@ let class_expr sub {cl_desc; cl_env; _} = | Tcl_apply (cl, args) -> sub.class_expr sub cl; List.iter (function - | (_, Arg exp) -> sub.expr sub exp - | (_, Omitted o) -> sub.env sub o.ty_env) + | (_, Arg (exp, _)) -> sub.expr sub exp + | (_, Omitted _) -> ()) args | Tcl_let (rec_flag, value_bindings, ivars, cl) -> sub.value_bindings sub (rec_flag, value_bindings); diff --git a/ocaml/typing/tast_mapper.ml b/ocaml/typing/tast_mapper.ml index 40b70425734..b39623f5ead 100644 --- a/ocaml/typing/tast_mapper.ml +++ b/ocaml/typing/tast_mapper.ml @@ -298,19 +298,17 @@ let expr sub x = | Texp_let (rec_flag, list, exp) -> let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in Texp_let (rec_flag, list, sub.expr sub exp) - | Texp_function { arg_label; param; cases; - partial; region; curry; warnings; arg_mode; alloc_mode } -> + | Texp_function { arg_label; param; cases; partial; region; curry; + warnings; arg_mode; arg_sort; ret_sort; alloc_mode } -> let cases = List.map (sub.case sub) cases in - Texp_function { arg_label; param; cases; - partial; region; curry; warnings; arg_mode; alloc_mode } + Texp_function { arg_label; param; cases; partial; region; curry; + warnings; arg_mode; arg_sort; ret_sort; alloc_mode } | Texp_apply (exp, list, pos, am) -> Texp_apply ( sub.expr sub exp, List.map (function - | (lbl, Arg exp) -> (lbl, Arg (sub.expr sub exp)) - | (lbl, Omitted o) -> - let o' = { o with ty_env = sub.env sub o.ty_env } in - (lbl, Omitted o')) + | (lbl, Arg (exp, sort)) -> (lbl, Arg (sub.expr sub exp, sort)) + | (lbl, Omitted o) -> (lbl, Omitted o)) list, pos, am ) @@ -375,7 +373,7 @@ let expr sub x = | Texp_while wh -> Texp_while { wh_cond = sub.expr sub wh.wh_cond; wh_body = sub.expr sub wh.wh_body; - wh_body_layout = wh.wh_body_layout + wh_body_sort = wh.wh_body_sort } | Texp_for tf -> Texp_for {tf with for_from = sub.expr sub tf.for_from; @@ -424,12 +422,15 @@ let expr sub x = Texp_object (sub.class_structure sub cl, sl) | Texp_pack mexpr -> Texp_pack (sub.module_expr sub mexpr) - | Texp_letop {let_; ands; param; body; partial; warnings} -> + | Texp_letop {let_; ands; param; param_sort; body; body_sort; partial; + warnings} -> Texp_letop{ let_ = sub.binding_op sub let_; ands = List.map (sub.binding_op sub) ands; param; + param_sort; body = sub.case sub body; + body_sort; partial; warnings } @@ -621,7 +622,7 @@ let class_expr sub x = Tcl_apply ( sub.class_expr sub cl, List.map (function - | (lbl, Arg exp) -> (lbl, Arg (sub.expr sub exp)) + | (lbl, Arg (exp, sort)) -> (lbl, Arg (sub.expr sub exp, sort)) | (lbl, Omitted o) -> (lbl, Omitted o)) args ) diff --git a/ocaml/typing/typeclass.ml b/ocaml/typing/typeclass.ml index d6f96ec8a13..347f1387098 100644 --- a/ocaml/typing/typeclass.ml +++ b/ocaml/typing/typeclass.ml @@ -1280,16 +1280,24 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let use_arg sarg l' = Arg ( if not optional || Btype.is_optional l' then - type_argument val_env sarg ty ty0 + let arg = type_argument val_env sarg ty ty0 in + arg, Sort.value else let ty' = extract_option_type val_env ty and ty0' = extract_option_type val_env ty0 in let arg = type_argument val_env sarg ty' ty0' in - option_some val_env arg Value_mode.global + option_some val_env arg Value_mode.global, + (* CR layouts v5: Change the sort when options can hold + non-values. *) + Sort.value ) in let eliminate_optional_arg () = - Arg (option_none val_env ty0 Location.none) + Arg (option_none val_env ty0 Location.none, + (* CR layouts v5: Change the sort when options can hold + non-values. *) + Sort.value + ) in let remaining_sargs, arg = if ignore_labels then begin @@ -1324,7 +1332,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let mode_closure = Alloc_mode.global in let mode_arg = Alloc_mode.global in let mode_ret = Alloc_mode.global in - Omitted { mode_closure; mode_arg; mode_ret; ty_arg = ty; ty_env = val_env } + let sort_arg = Sort.value in + Omitted { mode_closure; mode_arg; mode_ret; sort_arg } end in let omitted = diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index d170bfd7928..17cc37ea608 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -192,10 +192,24 @@ type error = | Layout_not_enabled of Layout.const | Unboxed_int_literals_not_supported | Unboxed_float_literals_not_supported + | Function_type_not_rep of type_expr * Layout.Violation.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error +let error_of_filter_arrow_failure ~explanation in_function ty_fun + : filter_arrow_failure -> _ = function + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) + end + | Layout_error (ty, err) -> Function_type_not_rep (ty, err) + (* Forward declaration, to be filled in by Typemod.type_module *) let type_module = @@ -3000,6 +3014,7 @@ type untyped_apply_arg = { sarg : Parsetree.expression; ty_arg : type_expr; ty_arg0 : type_expr; + sort_arg : sort; commuted : bool; mode_fun : Alloc_mode.t; mode_arg : Alloc_mode.t; @@ -3007,11 +3022,13 @@ type untyped_apply_arg = | Unknown_arg of { sarg : Parsetree.expression; ty_arg_mono : type_expr; + sort_arg : sort; mode_fun : Alloc_mode.t; mode_arg : Alloc_mode.t; } | Eliminated_optional_arg of { mode_fun: Alloc_mode.t; ty_arg : type_expr; + sort_arg : sort; mode_arg : Alloc_mode.t; level: int; } @@ -3019,7 +3036,8 @@ type untyped_omitted_param = { mode_fun: Alloc_mode.t; ty_arg : type_expr; mode_arg : Alloc_mode.t; - level: int; } + level: int; + sort_arg : sort } let is_partial_apply args = List.exists @@ -3121,12 +3139,13 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar match sargs with | [] -> ty_fun, mode_fun, List.rev rev_args | (lbl, sarg) :: rest -> - let (mode_arg, ty_arg_mono, mode_ret, ty_res) = + let (sort_arg, mode_arg, ty_arg_mono, mode_ret, ty_res) = let ty_fun = expand_head env ty_fun in match get_desc ty_fun with | Tvar _ -> + let sort_arg = Sort.new_var () in let ty_arg_mono = - newvar (Layout.of_new_sort_var ~why:Function_argument) + newvar (Layout.of_sort ~why:Function_argument sort_arg) in let ty_arg = newmono ty_arg_mono in let ty_res = @@ -3143,10 +3162,16 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar let kind = (lbl, mode_arg, mode_ret) in unify env ty_fun (newty (Tarrow(kind,ty_arg,ty_res,commu_var ()))); - (mode_arg, ty_arg_mono, mode_ret, ty_res) + (sort_arg, mode_arg, ty_arg_mono, mode_ret, ty_res) | Tarrow ((l, mode_arg, mode_ret), ty_arg, ty_res, _) when labels_match ~param:l ~arg:lbl -> - (mode_arg, tpoly_get_mono ty_arg, mode_ret, ty_res) + let sort_arg = + match type_sort ~why:Function_argument env ty_arg with + | Ok sort -> sort + | Error err -> raise(Error(funct.exp_loc, env, + Function_type_not_rep (ty_arg,err))) + in + (sort_arg, mode_arg, tpoly_get_mono ty_arg, mode_ret, ty_res) | td -> let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in let ty_res = remaining_function_type ty_fun mode_fun rev_args in @@ -3160,9 +3185,11 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar | _ -> raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) - in - let arg = Unknown_arg { sarg; ty_arg_mono; mode_fun; mode_arg } in - loop ty_res mode_ret ((lbl, Arg arg) :: rev_args) rest + in + let arg = + Unknown_arg { sarg; ty_arg_mono; mode_fun; mode_arg; sort_arg } + in + loop ty_res mode_ret ((lbl, Arg arg) :: rev_args) rest in loop ty_fun mode_fun rev_args sargs @@ -3170,10 +3197,11 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret let warned = ref false in let rec loop ty_fun ty_fun0 mode_fun rev_args sargs = let ty_fun' = expand_head env ty_fun in - match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + match get_desc ty_fun', get_desc (expand_head env ty_fun0), sargs with | Tarrow (ad, ty_arg, ty_ret, com), - Tarrow (_, ty_arg0, ty_ret0, _) - when sargs <> [] && is_commu_ok com -> + Tarrow (_, ty_arg0, ty_ret0, _), + (_, sarg1) :: _ + when is_commu_ok com -> let lv = get_level ty_fun' in let (l, mode_arg, mode_ret) = ad in let may_warn loc w = @@ -3183,6 +3211,11 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret Location.prerr_warning loc w end in + let sort_arg = match type_sort ~why:Function_argument env ty_arg with + | Ok sort -> sort + | Error err -> raise(Error(sarg1.pexp_loc, env, + Function_type_not_rep(ty_arg, err))) + in let name = label_name l and optional = is_optional l in let use_arg ~commuted sarg l' = @@ -3191,7 +3224,7 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret may_warn sarg.pexp_loc (Warnings.Not_principal "using an optional argument here"); Arg (Known_arg - { sarg; ty_arg; ty_arg0; commuted; + { sarg; ty_arg; ty_arg0; commuted; sort_arg; mode_fun; mode_arg; wrapped_in_some }) in let eliminate_optional_arg () = @@ -3199,7 +3232,7 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret (Warnings.Non_principal_labels "eliminated optional argument"); Arg (Eliminated_optional_arg - { mode_fun; ty_arg; mode_arg; level = lv }) + { mode_fun; ty_arg; mode_arg; sort_arg; level = lv }) in let remaining_sargs, arg = if ignore_labels then begin @@ -3242,7 +3275,7 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret it. *) may_warn funct.exp_loc (Warnings.Non_principal_labels "commuted an argument"); - Omitted { mode_fun; ty_arg; mode_arg; level = lv } + Omitted { mode_fun; ty_arg; mode_arg; level = lv; sort_arg } end in loop ty_ret ty_ret0 mode_ret ((l, arg) :: rev_args) remaining_sargs @@ -3258,11 +3291,11 @@ let type_omitted_parameters expected_mode env ty_ret mode_ret args = List.fold_left (fun (ty_ret, mode_ret, open_args, closed_args, args) (lbl, arg) -> match arg with - | Arg (exp, exp_mode) -> + | Arg (exp, exp_mode, sort) -> let open_args = (exp_mode, exp) :: open_args in - let args = (lbl, Arg exp) :: args in + let args = (lbl, Arg (exp, sort)) :: args in (ty_ret, mode_ret, open_args, closed_args, args) - | Omitted { mode_fun; ty_arg; mode_arg; level } -> + | Omitted { mode_fun; ty_arg; mode_arg; level; sort_arg } -> let arrow_desc = (lbl, mode_arg, mode_ret) in let ty_ret = newty2 ~level @@ -3280,7 +3313,7 @@ let type_omitted_parameters expected_mode env ty_ret mode_ret args = let open_args = [] in let mode_closure = Alloc_mode.join (mode_fun :: closed_args) in register_allocation_mode mode_closure; - let arg = Omitted { mode_closure; mode_arg; mode_ret; ty_arg; ty_env = env } in + let arg = Omitted { mode_closure; mode_arg; mode_ret; sort_arg } in let args = (lbl, arg) :: args in (ty_ret, mode_closure, open_args, closed_args, args)) (ty_ret, mode_ret, [], [], []) (List.rev args) @@ -3373,7 +3406,7 @@ let rec is_nonexpansive exp = Val_prim {Primitive.prim_name = ("%raise" | "%reraise" | "%raise_notrace")}}, Id_prim _) }, - [Nolabel, Arg e], _, _) -> + [Nolabel, Arg (e, _)], _, _) -> is_nonexpansive e | Texp_array (_, _ :: _, _) | Texp_apply _ @@ -3433,7 +3466,7 @@ and is_nonexpansive_opt = function and is_nonexpansive_arg = function | Omitted _ -> true - | Arg e -> is_nonexpansive e + | Arg (e, _) -> is_nonexpansive e let maybe_expansive e = not (is_nonexpansive e) @@ -3637,20 +3670,11 @@ let rec type_function_approx env loc label spato sexp in_function ty_expected = | Some (loc, ty) -> loc, ty | None -> loc, ty_expected in - let (arg_mode, ty_arg, _, ty_res) = + let { ty_arg; arg_mode; ty_ret; _ } = try filter_arrow env ty_expected label ~force_tpoly:(not has_poly) with Filter_arrow_failed err -> - let explanation = None in - let err = match err with - | Unification_error unif_err -> - Expr_type_clash(unif_err, explanation, None) - | Label_mismatch { got; expected; expected_type} -> - Abstract_wrong_label { got; expected; expected_type; explanation } - | Not_a_function -> begin - match in_function with - | Some _ -> Too_many_arguments(ty_fun, explanation) - | None -> Not_a_function(ty_fun, explanation) - end + let err = + error_of_filter_arrow_failure ~explanation:None in_function ty_fun err in raise (Error(loc_fun, env, err)) in @@ -3663,7 +3687,7 @@ let rec type_function_approx env loc label spato sexp in_function ty_expected = | Some spat -> type_pattern_approx env spat ty_arg end; let in_function = Some (loc_fun, ty_fun) in - type_approx_aux env sexp in_function ty_res + type_approx_aux env sexp in_function ty_ret and type_approx_aux env sexp in_function ty_expected = match Jane_syntax.Expression.of_ast sexp with @@ -4922,12 +4946,12 @@ and type_expect_ exp_env = env } end | Pexp_sequence(sexp1, sexp2) -> - let exp1 = type_statement ~explanation:Sequence_left_hand_side - env sexp1 in + let exp1, sort1 = + type_statement ~explanation:Sequence_left_hand_side env sexp1 + in let exp2 = type_expect env expected_mode sexp2 ty_expected_explained in - let layout = type_layout env exp1.exp_type in re { - exp_desc = Texp_sequence(exp1, layout, exp2); + exp_desc = Texp_sequence(exp1, sort1, exp2); exp_loc = loc; exp_extra = []; exp_type = exp2.exp_type; exp_attributes = sexp.pexp_attributes; @@ -4941,14 +4965,13 @@ and type_expect_ in let body_env = Env.add_region_lock env in let position = RTail (Value_mode.local, FNontail) in - let wh_body = + let wh_body, wh_body_sort = type_statement ~explanation:While_loop_body ~position body_env sbody in - let wh_body_layout = Ctype.type_layout env wh_body.exp_type in rue { exp_desc = - Texp_while {wh_cond; wh_body; wh_body_layout}; + Texp_while {wh_cond; wh_body; wh_body_sort}; exp_loc = loc; exp_extra = []; exp_type = instance Predef.type_unit; exp_attributes = sexp.pexp_attributes; @@ -4967,13 +4990,12 @@ and type_expect_ in let new_env = Env.add_region_lock new_env in let position = RTail (Value_mode.local, FNontail) in - let for_body = + let for_body, for_body_sort = type_statement ~explanation:For_loop_body ~position new_env sbody in - let for_body_layout = Ctype.type_layout env for_body.exp_type in rue { exp_desc = Texp_for {for_id; for_pat = param; for_from; for_to; - for_dir = dir; for_body; for_body_layout }; + for_dir = dir; for_body; for_body_sort }; exp_loc = loc; exp_extra = []; exp_type = instance Predef.type_unit; exp_attributes = sexp.pexp_attributes; @@ -5504,37 +5526,43 @@ and type_expect_ exp_env = env; } | Pexp_letop{ let_ = slet; ands = sands; body = sbody } -> - let rec loop spat_acc ty_acc sands = + let rec loop spat_acc ty_acc ty_acc_sort sands = match sands with - | [] -> spat_acc, ty_acc + | [] -> spat_acc, ty_acc, ty_acc_sort | { pbop_pat = spat; _} :: rest -> (* CR layouts v5: eliminate value requirement *) let ty = newvar (Layout.value ~why:Tuple_element) in let loc = Location.ghostify slet.pbop_op.loc in let spat_acc = Ast_helper.Pat.tuple ~loc [spat_acc; spat] in let ty_acc = newty (Ttuple [ty_acc; ty]) in - loop spat_acc ty_acc rest + loop spat_acc ty_acc Sort.value rest in if !Clflags.principal then begin_def (); let let_loc = slet.pbop_op.loc in let op_path, op_desc = type_binding_op_ident env slet.pbop_op in let op_type = instance op_desc.val_type in - let spat_params, ty_params = - let initial_layout = match sands with - | [] -> Layout.of_new_sort_var ~why:Function_argument + let spat_params, ty_params, param_sort = + let initial_layout, initial_sort = match sands with + | [] -> + let sort = Sort.new_var () in + Layout.of_sort ~why:Function_argument sort, sort (* CR layouts v5: eliminate value requirement for tuple elements *) - | _ -> Layout.value ~why:Tuple_element + | _ -> Layout.value ~why:Tuple_element, Sort.value in - loop slet.pbop_pat (newvar initial_layout) sands + loop slet.pbop_pat (newvar initial_layout) initial_sort sands in + let body_sort = Sort.new_var () in let ty_func_result = - newvar (Layout.of_new_sort_var ~why:Function_result) + newvar (Layout.of_sort ~why:Function_result body_sort) in let arrow_desc = Nolabel, Alloc_mode.global, Alloc_mode.global in let ty_func = newty (Tarrow(arrow_desc, newmono ty_params, ty_func_result, commu_ok)) in - let ty_result = newvar (Layout.of_new_sort_var ~why:Function_result) in + let op_result_sort = Sort.new_var () in + let ty_result = + newvar (Layout.of_sort ~why:Function_result op_result_sort) + in let ty_andops = newvar (Layout.of_new_sort_var ~why:Function_argument) in let ty_op = newty (Tarrow(arrow_desc, newmono ty_andops, @@ -5575,12 +5603,14 @@ and type_expect_ bop_op_path = op_path; bop_op_val = op_desc; bop_op_type = op_type; + bop_op_return_sort = op_result_sort; bop_exp = exp; bop_loc = slet.pbop_loc; } in let warnings = Warnings.backup () in let desc = - Texp_letop{let_; ands; param; body; partial; warnings} + Texp_letop{let_; ands; param; param_sort; body; body_sort; partial; + warnings} in rue { exp_desc = desc; exp_loc = sexp.pexp_loc; @@ -5764,7 +5794,7 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) | _ -> false in let ty_expected' = instance ty_expected in - let (arg_mode, ty_arg, ret_mode, ty_res) = + let { ty_arg; arg_mode; arg_sort; ty_ret; ret_mode; ret_sort } = let force_tpoly = (* If [has_poly] is true then we rely on the later call to type_pat to enforce the invariant that the parameter type @@ -5773,16 +5803,8 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) in try filter_arrow env ty_expected' arg_label ~force_tpoly with Filter_arrow_failed err -> - let err = match err with - | Unification_error unif_err -> - Expr_type_clash(unif_err, explanation, None) - | Label_mismatch { got; expected; expected_type} -> - Abstract_wrong_label { got; expected; expected_type; explanation } - | Not_a_function -> begin - match in_function with - | Some _ -> Too_many_arguments(ty_fun, explanation) - | None -> Not_a_function(ty_fun, explanation) - end + let err = + error_of_filter_arrow_failure ~explanation in_function ty_fun err in raise (Error(loc_fun, env, err)) in @@ -5792,7 +5814,7 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) if separate then begin end_def (); generalize_structure ty_arg; - generalize_structure ty_res + generalize_structure ty_ret end; if not has_poly && not (tpoly_is_mono ty_arg) && !Clflags.principal && get_level ty_arg < Btype.generic_level then begin @@ -5858,7 +5880,7 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) | Error () -> raise (Error (loc_fun, env, Function_returns_local)) end in - let ret_value_mode = expect_mode_cross env ty_res ret_value_mode in + let ret_value_mode = expect_mode_cross env ty_ret ret_value_mode in ret_value_mode, Final_arg { partial_mode = Alloc_mode.join [arg_mode; alloc_mode] } end @@ -5885,12 +5907,12 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) in let cases, partial = type_cases Value ?in_function env (simple_pat_mode arg_value_mode) - cases_expected_mode ty_arg_mono (mk_expected ty_res) true loc caselist in + cases_expected_mode ty_arg_mono (mk_expected ty_ret) true loc caselist in let not_nolabel_function ty = let ls, tvar = list_labels env ty in List.for_all ((<>) Nolabel) ls && not tvar in - if is_optional arg_label && not_nolabel_function ty_res then + if is_optional arg_label && not_nolabel_function ty_ret then Location.prerr_warning (List.hd cases).c_lhs.pat_loc Warnings.Unerasable_optional_argument; let param = name_cases "param" cases in @@ -5899,11 +5921,12 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) re { exp_desc = Texp_function - { arg_label; param; cases; partial; region; curry; warnings; arg_mode; alloc_mode }; + { arg_label; param; cases; partial; region; curry; warnings; + arg_mode; arg_sort; alloc_mode; ret_sort }; exp_loc = loc; exp_extra = []; exp_type = instance (newgenty (Tarrow((arg_label,arg_mode,ret_mode), - ty_arg, ty_res, commu_ok))); + ty_arg, ty_ret, commu_ok))); exp_attributes = attrs; exp_env = env } @@ -6328,7 +6351,9 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg option_none env (instance (tpoly_get_mono ty_arg)) sarg.pexp_loc in - make_args ((l, Arg ty) :: args) ty_fun + (* CR layouts v5: change value assumption below when we allow + non-values in structures. *) + make_args ((l, Arg (ty, Sort.value)) :: args) ty_fun | Tarrow ((l,_,_),_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' | Tvar _ -> List.rev args, ty_fun, false @@ -6379,13 +6404,25 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg in let eta_mode = Value_mode.local_to_regional (Value_mode.of_alloc marg) in let eta_pat, eta_var = var_pair ~mode:eta_mode "eta" ty_arg in + (* CR layouts v10: When we add abstract layouts, the eta expansion here + becomes impossible in some cases - we'll need better errors. For test + cases, look toward the end of + typing-layouts-missing-cmi/function_arg.ml *) + let type_sort ~why ty = + match type_sort ~why env ty with + | Ok sort -> sort + | Error err -> + raise(Error(sarg.pexp_loc, env, Function_type_not_rep (ty, err))) + in + let arg_sort = type_sort ~why:Function_argument ty_arg in + let ret_sort = type_sort ~why:Function_result ty_res in let func texp = let ret_mode = Value_mode.of_alloc mret in let e = {texp with exp_type = ty_res; exp_desc = Texp_apply (texp, - args @ [Nolabel, Arg eta_var], Nontail, + args @ [Nolabel, Arg (eta_var, arg_sort)], Nontail, Value_mode.regional_to_global_alloc ret_mode)} in let cases = [case eta_pat e] in @@ -6398,7 +6435,8 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg exp_desc = Texp_function { arg_label = Nolabel; param; cases; partial = Total; region = false; curry; warnings = Warnings.backup (); - arg_mode = marg; alloc_mode } } + arg_mode = marg; arg_sort; ret_sort; + alloc_mode } } in Location.prerr_warning texp.exp_loc (Warnings.Eliminated_optional_arguments @@ -6407,12 +6445,10 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg (Warnings.Non_principal_labels "eliminated optional argument"); (* let-expand to have side effects *) let let_pat, let_var = var_pair ~mode:exp_mode "arg" texp.exp_type in - (* CR layouts v2: `vb_sort=Sort.value` below to change when we allow - non-value function arguments. *) re { texp with exp_type = ty_fun; exp_desc = Texp_let (Nonrecursive, - [{vb_pat=let_pat; vb_expr=texp; vb_sort=Sort.value; + [{vb_pat=let_pat; vb_expr=texp; vb_sort=arg_sort; vb_attributes=[]; vb_loc=Location.none; }], func let_var) } @@ -6427,7 +6463,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg) = match arg with - | Arg (Unknown_arg { sarg; ty_arg_mono; mode_arg }) -> + | Arg (Unknown_arg { sarg; ty_arg_mono; mode_arg; sort_arg }) -> let mode, _ = Alloc_mode.newvar_below mode_arg in let expected_mode = mode_argument ~funct ~index ~position ~partial_app mode in @@ -6438,9 +6474,9 @@ and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg) (* CR layouts v5: relax value requirement *) unify_exp env arg (type_option(newvar (Layout.value ~why:Type_argument))); - (lbl, Arg (arg, expected_mode.mode)) + (lbl, Arg (arg, expected_mode.mode, sort_arg)) | Arg (Known_arg { sarg; ty_arg; ty_arg0; - mode_arg; wrapped_in_some }) -> + mode_arg; wrapped_in_some; sort_arg }) -> let mode, _ = Alloc_mode.newvar_below mode_arg in let expected_mode = mode_argument ~funct ~index ~position ~partial_app mode in @@ -6496,10 +6532,10 @@ and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg) {arg with exp_type = instance arg.exp_type} end in - (lbl, Arg (arg, expected_mode.mode)) - | Arg (Eliminated_optional_arg { ty_arg; _ }) -> + (lbl, Arg (arg, expected_mode.mode, sort_arg)) + | Arg (Eliminated_optional_arg { ty_arg; sort_arg; _ }) -> let arg = option_none env (instance ty_arg) Location.none in - (lbl, Arg (arg, Value_mode.global)) + (lbl, Arg (arg, Value_mode.global, sort_arg)) | Omitted _ as arg -> (lbl, arg) and type_application env app_loc expected_mode pm @@ -6513,26 +6549,26 @@ and type_application env app_loc expected_mode pm | (* Special case for ignore: avoid discarding warning *) [Nolabel, sarg] when is_ignore funct -> if !Clflags.principal then begin_def () ; - let marg, ty_arg, mres, ty_res = + let {ty_arg; arg_mode; arg_sort; ty_ret; ret_mode} = filter_arrow_mono env (instance funct.exp_type) Nolabel in if !Clflags.principal then begin end_def (); - generalize_structure ty_res + generalize_structure ty_ret end; - let ap_mode = mres in + let ap_mode = ret_mode in let mode_res = - mode_cross_to_global env ty_res (Value_mode.of_alloc mres) + mode_cross_to_global env ty_ret (Value_mode.of_alloc ret_mode) in submode ~loc:app_loc ~env ~reason:Other mode_res expected_mode; - let marg = + let arg_mode = mode_argument ~funct ~index:0 ~position:(pm.apply_position) - ~partial_app:false marg + ~partial_app:false arg_mode in - let exp = type_expect env marg sarg (mk_expected ty_arg) in + let exp = type_expect env arg_mode sarg (mk_expected ty_arg) in check_partial_application ~statement:false exp; - ([Nolabel, Arg exp], ty_res, ap_mode, pm) + ([Nolabel, Arg (exp, arg_sort)], ty_ret, ap_mode, pm) | _ -> let ty = funct.exp_type in let ignore_labels = @@ -6566,8 +6602,7 @@ and type_application env app_loc expected_mode pm untyped_args in let ty_ret, mode_ret, args = - type_omitted_parameters expected_mode env - ty_ret mode_ret args + type_omitted_parameters expected_mode env ty_ret mode_ret args in check_local_application_complete ~env ~app_loc untyped_args; if !Clflags.principal then begin @@ -6694,9 +6729,14 @@ and type_statement ?explanation ?(position=RNontail) env sexp = begin_def(); let exp = type_exp env (mode_local_with_position position) sexp in end_def(); - let ty = expand_head env exp.exp_type - and tv = newvar (Layout.any ~why:Dummy_layout) - in + let ty = expand_head env exp.exp_type in + (* We're requiring the statement to have a representable layout. But that + doesn't actually rule out things like "assert false"---we'll just end up + getting a sort variable for its layout. *) + (* CR layouts v10: Abstract layouts will introduce cases where we really + have [any] and can't get a sort here. *) + let sort = Sort.new_var () in + let tv = newvar (Layout.of_sort ~why:Statement sort) in if is_Tvar ty && get_level ty > get_level tv then Location.prerr_warning (final_subexpression exp).exp_loc @@ -6706,11 +6746,11 @@ and type_statement ?explanation ?(position=RNontail) env sexp = let expected_ty = instance Predef.type_unit in with_explanation explanation (fun () -> unify_exp env exp expected_ty); - exp + exp, Sort.value else begin check_partial_application ~statement:true exp; unify_var env tv ty; - exp + exp, sort end (* Typing of match cases *) @@ -7285,7 +7325,10 @@ and type_andops env sarg sands expected_ty = let op_type = op_desc.val_type in let ty_arg = newvar (Layout.of_new_sort_var ~why:Function_argument) in let ty_rest = newvar (Layout.of_new_sort_var ~why:Function_argument) in - let ty_result = newvar (Layout.of_new_sort_var ~why:Function_result) in + let op_result_sort = Sort.new_var () in + let ty_result = + newvar (Layout.of_sort ~why:Function_result op_result_sort) + in let arrow_desc = (Nolabel,Alloc_mode.global,Alloc_mode.global) in let ty_rest_fun = newty (Tarrow(arrow_desc, newmono ty_arg, ty_result, commu_ok)) @@ -7318,6 +7361,7 @@ and type_andops env sarg sands expected_ty = bop_op_path = op_path; bop_op_val = op_desc; bop_op_type = op_type; + bop_op_return_sort = op_result_sort; bop_exp = exp; bop_loc = loc } in @@ -8370,6 +8414,11 @@ let report_error ~loc env = function | Unboxed_float_literals_not_supported -> Location.errorf ~loc "@[Unboxed float literals aren't supported yet.@]" + | Function_type_not_rep (ty,violation) -> + Location.errorf ~loc + "@[Function arguments and returns must be representable.@]@ %a" + (Layout.Violation.report_with_offender + ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation let report_error ~loc env err = Printtyp.wrap_printing_env ~error:true env diff --git a/ocaml/typing/typecore.mli b/ocaml/typing/typecore.mli index 44a7a07e1a7..84b1054a070 100644 --- a/ocaml/typing/typecore.mli +++ b/ocaml/typing/typecore.mli @@ -269,7 +269,7 @@ type error = | Layout_not_enabled of Layout.const | Unboxed_int_literals_not_supported | Unboxed_float_literals_not_supported - + | Function_type_not_rep of type_expr * Layout.Violation.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/ocaml/typing/typedecl.ml b/ocaml/typing/typedecl.ml index f49571ba3c8..48a5ad061c2 100644 --- a/ocaml/typing/typedecl.ml +++ b/ocaml/typing/typedecl.ml @@ -27,7 +27,7 @@ module String = Misc.Stdlib.String type native_repr_kind = Unboxed | Untagged -type layout_sort_loc = Cstr_tuple | Record +type layout_sort_loc = Cstr_tuple | Record | External type error = Repeated_parameter @@ -1105,7 +1105,6 @@ let update_decl_layout env dpath decl = | [{Types.cd_args;cd_loc} as cstr], Variant_unboxed -> begin match cd_args with | Cstr_tuple [ty,_] -> begin - (* CR layouts: check_representable should return the sort *) check_representable ~why:(Constructor_declaration 0) env cd_loc Cstr_tuple ty; let layout = Ctype.type_layout env ty in @@ -1885,11 +1884,11 @@ let error_if_has_deep_native_repr_attributes core_type = in default_iterator.typ this_iterator core_type -let make_native_repr env core_type ty ~global_repr = +let make_native_repr env core_type sort ty ~global_repr = error_if_has_deep_native_repr_attributes core_type; match get_native_repr_attribute core_type.ptyp_attributes ~global_repr with | Native_repr_attr_absent -> - Same_as_ocaml_repr + Same_as_ocaml_repr sort | Native_repr_attr_present kind -> begin match native_repr_of_type env kind ty with | None -> @@ -1903,6 +1902,19 @@ let prim_const_mode m = | Some Local -> Prim_local | None -> assert false +(* Note that [ty] is guaranteed not to contain sort variables because it was + produced by [type_scheme], which defaults them. Further, if ty is an arrow + we know its bits are representable, so [type_sort_external] can only fail + on externals with non-arrow types. *) +(* CR layouts v3: When we allow non-representable function args/returns, the + representability argument above isn't quite right. Decide whether we want to + allow non-representable types in external args/returns then. *) +let type_sort_external ~why env loc typ = + match Ctype.type_sort ~why env typ with + | Ok s -> Sort.get_default_value s + | Error err -> + raise (Error (loc,Layout_sort {lloc = External; typ; err})) + let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = match core_type.ptyp_desc, get_desc ty, get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None @@ -1912,7 +1924,10 @@ let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = | Ptyp_arrow (_, ct1, ct2), Tarrow ((_,marg,mret), t1, t2, _), _ when not (Builtin_attributes.has_curry core_type.ptyp_attributes) -> let t1, _ = Btype.tpoly_get_poly t1 in - let repr_arg = make_native_repr env ct1 t1 ~global_repr in + let sort_arg = + type_sort_external ~why:External_argument env ct1.ptyp_loc t1 + in + let repr_arg = make_native_repr env ct1 sort_arg t1 ~global_repr in let mode = if Builtin_attributes.has_local_opt ct1.ptyp_attributes then Prim_poly @@ -1921,7 +1936,7 @@ let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 (prim_const_mode mret) ~global_repr in - ((mode,repr_arg) :: repr_args, repr_res) + ((mode, repr_arg) :: repr_args, repr_res) | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ -> parse_native_repr_attributes env t ty rmode ~global_repr | _ -> @@ -1930,8 +1945,10 @@ let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = then Prim_poly else rmode in - ([], (rmode, make_native_repr env core_type ty ~global_repr)) - + let sort_res = + type_sort_external ~why:External_result env core_type.ptyp_loc ty + in + ([], (rmode, make_native_repr env core_type sort_res ty ~global_repr)) let check_unboxable env loc ty = let rec check_type acc ty : Path.Set.t = @@ -2508,6 +2525,7 @@ let report_error ppf = function match lloc with | Cstr_tuple -> "Constructor argument" | Record -> "Record element" + | External -> "External" in fprintf ppf "@[%s types must have a representable layout.@ \ %a@]" s (Layout.Violation.report_with_offender diff --git a/ocaml/typing/typedecl.mli b/ocaml/typing/typedecl.mli index e0c3556b8e3..3c0b732b150 100644 --- a/ocaml/typing/typedecl.mli +++ b/ocaml/typing/typedecl.mli @@ -66,7 +66,7 @@ val is_fixed_type : Parsetree.type_declaration -> bool type native_repr_kind = Unboxed | Untagged (* Records reason for a layout representability requirement in errors. *) -type layout_sort_loc = Cstr_tuple | Record +type layout_sort_loc = Cstr_tuple | Record | External type error = Repeated_parameter diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index d388bb7d6a9..d4ccd1ddbbc 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -113,6 +113,8 @@ and expression_desc = region : bool; curry : fun_curry_state; warnings : Warnings.state; arg_mode : Types.alloc_mode; + arg_sort : sort; + ret_sort : sort; alloc_mode : Types.alloc_mode } | Texp_apply of expression * (arg_label * apply_arg) list * apply_position * Types.alloc_mode | Texp_match of expression * sort * computation case list * partial @@ -134,11 +136,11 @@ and expression_desc = | Texp_list_comprehension of comprehension | Texp_array_comprehension of mutable_flag * comprehension | Texp_ifthenelse of expression * expression * expression option - | Texp_sequence of expression * layout * expression + | Texp_sequence of expression * sort * expression | Texp_while of { wh_cond : expression; wh_body : expression; - wh_body_layout : layout + wh_body_sort : sort } | Texp_for of { for_id : Ident.t; @@ -147,7 +149,7 @@ and expression_desc = for_to : expression; for_dir : direction_flag; for_body : expression; - for_body_layout : Layouts.layout; + for_body_sort : sort; } | Texp_send of expression * meth * apply_position * Types.alloc_mode | Texp_new of @@ -167,7 +169,9 @@ and expression_desc = let_ : binding_op; ands : binding_op list; param : Ident.t; + param_sort : sort; body : value case; + body_sort : sort; partial : partial; warnings : Warnings.state; } @@ -229,6 +233,7 @@ and binding_op = bop_op_name : string loc; bop_op_val : Types.value_description; bop_op_type : Types.type_expr; + bop_op_return_sort : sort; bop_exp : expression; bop_loc : Location.t; } @@ -241,10 +246,9 @@ and omitted_parameter = { mode_closure : alloc_mode; mode_arg : alloc_mode; mode_ret : alloc_mode; - ty_arg : Types.type_expr; - ty_env : Env.t } + sort_arg : sort } -and apply_arg = (expression, omitted_parameter) arg_or_omitted +and apply_arg = (expression * sort, omitted_parameter) arg_or_omitted and apply_position = | Tail diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index 0ef4e177160..a1dffe4d3d8 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -214,6 +214,8 @@ and expression_desc = region : bool; curry : fun_curry_state; warnings : Warnings.state; arg_mode : Types.alloc_mode; + arg_sort : Layouts.sort; + ret_sort : Layouts.sort; alloc_mode : Types.alloc_mode} (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. See {!Parsetree} for more details. @@ -303,15 +305,11 @@ and expression_desc = | Texp_list_comprehension of comprehension | Texp_array_comprehension of mutable_flag * comprehension | Texp_ifthenelse of expression * expression * expression option - | Texp_sequence of expression * Layouts.layout * expression - (* CR layouts v5: The layout above is only used for the void sanity check now. - Remove it at an appropriate time. *) + | Texp_sequence of expression * Layouts.sort * expression | Texp_while of { wh_cond : expression; wh_body : expression; - wh_body_layout : Layouts.layout - (* CR layouts v5: The layout above is only used for the void sanity check - now. Remove it at an appropriate time. *) + wh_body_sort : Layouts.sort } | Texp_for of { for_id : Ident.t; @@ -320,9 +318,7 @@ and expression_desc = for_to : expression; for_dir : direction_flag; for_body : expression; - for_body_layout : Layouts.layout; - (* CR layouts v5: The layout above is only used for the void sanity check - now. Remove it at an appropriate time. *) + for_body_sort : Layouts.sort; } | Texp_send of expression * meth * apply_position * Types.alloc_mode (** [alloc_mode] is the allocation mode of the result *) @@ -343,7 +339,9 @@ and expression_desc = let_ : binding_op; ands : binding_op list; param : Ident.t; + param_sort : Layouts.sort; body : value case; + body_sort : Layouts.sort; partial : partial; warnings : Warnings.state; } @@ -416,6 +414,7 @@ and binding_op = bop_op_type : Types.type_expr; (* This is the type at which the operator was used. It is always an instance of [bop_op_val.val_type] *) + bop_op_return_sort : Layouts.sort; bop_exp : expression; bop_loc : Location.t; } @@ -428,12 +427,9 @@ and omitted_parameter = { mode_closure : Types.alloc_mode; mode_arg : Types.alloc_mode; mode_ret : Types.alloc_mode; - (* CR ncourant: actually, we only need this to be able to compute the layout - in [Translcore], change this when merging with the front-end. *) - ty_arg : Types.type_expr; - ty_env : Env.t} + sort_arg : Layouts.sort } -and apply_arg = (expression, omitted_parameter) arg_or_omitted +and apply_arg = (expression * Layouts.sort, omitted_parameter) arg_or_omitted and apply_position = | Tail (* must be tail-call optimised *) diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 1978a50b75f..48eb70aebee 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -27,6 +27,8 @@ open Lambda stuff. *) type error = Non_value_layout of type_expr * Layout.Violation.t + | Non_value_sort of type_expr + | Non_value_sort_unknown_ty exception Error of Location.t * error @@ -484,20 +486,41 @@ let value_kind env loc ty = in value_kind -(* CR layouts v2: We'll have other layouts. Think about what to do with the - sanity check in value_kind. *) -let layout env loc ty = Lambda.Pvalue (value_kind env loc ty) +(* CR layouts v2: We are planning to put a sanity check here that you don't get + passed float# as the sort unless layouts_alpha is on. This violates our + previous rule that extensions only control syntax, but seems like a nice + implementation of a sanity check, since the availability of the Float_u + module will result in ways to get at unboxed floats that aren't just writing + #float in your program. -let function_return_layout env loc ty = + We also do the void sanity check here. We do it in value_kind as well, + because the sort argument here is sometimes not computed from the type or + typed tree, but just one of the defaults from layouts.ml. +*) +let layout env loc sort ty = + match Layouts.Sort.get_default_value sort with + | Void -> raise (Error (loc, Non_value_sort ty)) + | Value -> Lambda.Pvalue (value_kind env loc ty) + +let layout_of_sort loc sort = + match Layouts.Sort.get_default_value sort with + | Void -> raise (Error (loc, Non_value_sort_unknown_ty)) + | Value -> Lambda.Pvalue Pgenval + +let function_return_layout env loc sort ty = match is_function_type env ty with - | Some (_lhs, rhs) -> layout env loc rhs + | Some (_lhs, rhs) -> layout env loc sort rhs | None -> Misc.fatal_errorf "function_return_layout called on non-function type" -let function2_return_layout env loc ty = +let function2_return_layout env loc sort ty = match is_function_type env ty with - | Some (_lhs, rhs) -> function_return_layout env loc rhs + | Some (_lhs, rhs) -> function_return_layout env loc sort rhs | None -> Misc.fatal_errorf "function_return_layout called on non-function type" +let function_arg_layout env loc sort ty = + match is_function_type env ty with + | Some (arg_type, _) -> layout env loc sort arg_type + | None -> Misc.fatal_error "function_arg_layout called on non-function type" (** Whether a forward block is needed for a lazy thunk on a value, i.e. if the value can be represented as a float/forward/lazy *) @@ -559,6 +582,15 @@ let report_error ppf = function the Jane Street compilers team.@ %a" (Layout.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) err + | Non_value_sort ty -> + fprintf ppf + "Non-value detected in [Typeopt.layout] as sort for type@ %a.@ \ + Please report this error to the Jane Street compilers team." + Printtyp.type_expr ty + | Non_value_sort_unknown_ty -> + fprintf ppf + "Non-value detected in [layout_of_sort]@ Please report this \ + error to the Jane Street compilers team." let () = Location.register_error_of_exn diff --git a/ocaml/typing/typeopt.mli b/ocaml/typing/typeopt.mli index 767b4ac4683..262e705fa45 100644 --- a/ocaml/typing/typeopt.mli +++ b/ocaml/typing/typeopt.mli @@ -30,17 +30,33 @@ val bigarray_type_kind_and_layout : Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout (* CR layouts: `layout` should have a `sort` argument. *) -(* CR layouts v2: [layout], [function_return_layout] and - [function2_return_layout] have had location arguments added just to support - the void check error message. These arguments can be removed when we're - happy to take that check out. *) -val layout : Env.t -> Location.t -> Types.type_expr -> Lambda.layout +(* CR layouts v2: [layout], [function_return_layout], [function2_return_layout], + and [layout_of_sort] have had location arguments added just to support the + void check error message. These arguments can be removed when we're happy to + take that check out. *) +val layout : + Env.t -> Location.t -> Layouts.sort -> Types.type_expr -> Lambda.layout +(* This translates a type system sort to a lambda layout. The function [layout] + gives a more precise result---this should only be used when the precise + Lambda.layout isn't needed for optimization. *) +val layout_of_sort : Location.t -> Layouts.sort -> Lambda.layout + +(* Given a function type and the sort of its return type, compute the layout of + its return type. *) val function_return_layout : - Env.t -> Location.t -> Types.type_expr -> Lambda.layout -(* Gives the return layout of a function with two arguments. *) + Env.t -> Location.t -> Layouts.sort -> Types.type_expr -> Lambda.layout + +(* Given a function type with two arguments and the sort of its return type, + compute the layout of its return type. *) val function2_return_layout : - Env.t -> Location.t -> Types.type_expr -> Lambda.layout + Env.t -> Location.t -> Layouts.sort -> Types.type_expr -> Lambda.layout + +(* Given a function type and the sort of its argument, compute the layout + of its argument. Fails loudly if the type isn't a function type. *) +val function_arg_layout : + Env.t -> Location.t -> Layouts.sort -> Types.type_expr -> Lambda.layout + val classify_lazy_argument : Typedtree.expression -> [ `Constant_or_function diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index 08fa37d8a0f..f10866552f0 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -493,7 +493,7 @@ let expression sub exp = List.fold_right (fun (label, arg) list -> match arg with | Omitted _ -> list - | Arg exp -> (label, sub.expr sub exp) :: list + | Arg (exp, _) -> (label, sub.expr sub exp) :: list ) list []) | Texp_match (exp, _, cases, _) -> Pexp_match (sub.expr sub exp, List.map (sub.case sub) cases) @@ -835,7 +835,7 @@ let class_expr sub cexpr = List.fold_right (fun (label, expo) list -> match expo with | Omitted _ -> list - | Arg exp -> (label, sub.expr sub exp) :: list + | Arg (exp, _) -> (label, sub.expr sub exp) :: list ) args []) | Tcl_let (rec_flat, bindings, _ivars, cl) ->