From de57bf34719ada30b874cd2707d810def6a01314 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 21 Aug 2026 16:14:15 +0200 Subject: [PATCH 1/7] Replace constructor ordinals with semantic identity and representation Constructors no longer carry positional integer tags anywhere in the compiler. Types.constructor_tag (Cstr_constant/Cstr_block of int) is replaced by a semantic identity (declaring type path + name for ordinary constructors, path for extensions), and every consumer now answers its actual question directly: - Parmatch compares constructors by identity and derives completeness from the type declaration instead of forging tags from counts; column coherence compares declared head types instead of count equality. - Matching keys constructor switches by canonical constructor cases and takes case counts from the variant layout in scope; the layout_from_construct_pattern mutable callback is inlined as a plain function and its polyfill removed. - Construction Lambda carries canonical runtime descriptors only: Const_pointer loses its ordinal, Lam_constant gains a first-class Const_constructor, and the tag ints are removed from Blk_constructor, Blk_record_inlined, Record_inlined, Lam.Pmakeblock, Const_block, and J.Caml_block. Constructors represented as numbers (@as(Int)) convert to genuine int constants so folding is preserved; JS block equality compares runtime descriptors instead of ordinals. - cstr_consts/cstr_nonconsts are removed; transparency is minted once in datarepr as cstr_transparent; Blk_constructor.num_nonconst is sourced from the declaration via the constructor identity. - unboxed_status collapses to type_representation = Boxed | Transparent; the internal -unboxed-types flag is removed and the runtime's Primitive_js_extern.res declares its unboxed records explicitly. Emitted JavaScript is unchanged across the test suite. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01YWw5GW8t4UDEWAzoqcDMkE --- analysis/reanalyze/src/dead_value.ml | 6 +- compiler/bsc/rescript_compiler_main.ml | 3 - compiler/core/bs_conditional_initial.ml | 2 - compiler/core/j.ml | 4 +- compiler/core/js_analyzer.ml | 10 +- compiler/core/js_dump.ml | 45 ++- compiler/core/js_exp_make.ml | 18 +- compiler/core/js_exp_make.mli | 2 - compiler/core/js_of_lam_block.ml | 4 +- compiler/core/js_of_lam_block.mli | 6 +- compiler/core/js_of_lam_variant.ml | 4 +- compiler/core/js_pass_flatten.ml | 5 +- .../core/js_pass_flatten_and_mark_dead.ml | 7 +- compiler/core/js_record_fold.ml | 3 +- compiler/core/js_record_iter.ml | 4 +- compiler/core/js_record_map.ml | 5 +- compiler/core/lam.ml | 114 ++++++-- compiler/core/lam.mli | 9 +- compiler/core/lam_analysis.ml | 13 +- compiler/core/lam_beta_reduce.ml | 4 +- compiler/core/lam_bounded_vars.ml | 4 +- compiler/core/lam_compile.ml | 160 ++++------- compiler/core/lam_compile_const.ml | 16 +- compiler/core/lam_compile_primitive.ml | 15 +- compiler/core/lam_constant_convert.ml | 29 +- compiler/core/lam_convert.ml | 48 ++-- compiler/core/lam_eta_conversion.ml | 6 +- compiler/core/lam_pass_alpha_conversion.ml | 4 +- compiler/core/lam_pass_collect.ml | 2 +- compiler/core/lam_pass_deep_flatten.ml | 8 +- compiler/core/lam_pass_eliminate_ref.ml | 2 +- compiler/core/lam_pass_lets_dce.ml | 11 +- compiler/core/lam_pass_remove_alias.ml | 6 +- compiler/core/lam_primitive.ml | 14 +- compiler/core/lam_primitive.mli | 9 +- compiler/core/lam_print.ml | 43 +-- compiler/core/lam_stats_export.ml | 2 +- compiler/core/lam_util.ml | 4 +- compiler/core/matching_polyfill.ml | 17 -- compiler/core/matching_polyfill.mli | 3 - compiler/core/polyvar_pattern_match.ml | 12 +- compiler/frontend/lam_constant.ml | 31 +- compiler/frontend/lam_constant.mli | 17 +- compiler/ml/ast_untagged_variants.ml | 140 +++++++-- compiler/ml/clflags.ml | 2 - compiler/ml/clflags.mli | 2 - compiler/ml/ctype.ml | 4 +- compiler/ml/datarepr.ml | 43 ++- compiler/ml/env.ml | 12 +- compiler/ml/includecore.ml | 4 +- compiler/ml/lambda.ml | 62 ++-- compiler/ml/lambda.mli | 44 +-- compiler/ml/matching.ml | 272 ++++++++++-------- compiler/ml/matching.mli | 6 - compiler/ml/parmatch.ml | 123 ++++---- compiler/ml/parmatch.mli | 2 +- compiler/ml/predef.ml | 4 +- compiler/ml/printlambda.ml | 32 ++- compiler/ml/printtyp.ml | 4 +- compiler/ml/printtyped.ml | 2 +- compiler/ml/rec_check.ml | 10 +- compiler/ml/subst.ml | 2 +- compiler/ml/switch.ml | 25 +- compiler/ml/switch.mli | 9 +- compiler/ml/transl_recmodule.ml | 30 +- compiler/ml/translcore.ml | 131 +++++---- compiler/ml/typecore.ml | 6 +- compiler/ml/typedecl.ml | 54 ++-- compiler/ml/typemod.ml | 2 +- compiler/ml/typeopt.ml | 2 +- compiler/ml/types.ml | 69 ++--- compiler/ml/types.mli | 48 ++-- .../@rescript/runtime/Primitive_js_extern.res | 46 ++- 73 files changed, 990 insertions(+), 933 deletions(-) diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml index fe107db278f..e6188790cab 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -230,11 +230,11 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees ( _, { cstr_loc = {Location.loc_start = pos_to; loc_ghost} as loc_to; - cstr_tag; + cstr_identity; }, _ ) -> - (match cstr_tag with - | Cstr_extension path -> + (match cstr_identity with + | Extension_constructor path -> path |> Dead_exception.mark_as_used ~config ~refs ~file_deps ~cross_file ~binding ~loc_from ~loc_to diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 23b6dfbbb79..c1837ee4f79 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -370,9 +370,6 @@ let command_line_flags : (string * Bsc_args.spec * string) array = "*internal* Set gentype bsb project root (workspace root containing \ .sourcedirs.json)" ); (******************************************************************************) - ( "-unboxed-types", - set Clflags.unboxed_types, - "*internal* Unannotated unboxable types will be unboxed" ); ("-nostdlib", set Js_config.no_stdlib, "*internal* Don't use stdlib"); ( "-color", string_call set_color_option, diff --git a/compiler/core/bs_conditional_initial.ml b/compiler/core/bs_conditional_initial.ml index 6c384407cb7..ba6bf27c51d 100644 --- a/compiler/core/bs_conditional_initial.ml +++ b/compiler/core/bs_conditional_initial.ml @@ -44,8 +44,6 @@ let setup_env () = Record_attributes_check.check_bs_attributes_inclusion; Builtin_attributes.check_duplicated_labels := Record_attributes_check.check_duplicated_labels; - Matching.names_from_construct_pattern := - Matching_polyfill.names_from_construct_pattern; Printtyp.print_res_poly_identifier := Res_printer.polyvar_ident_to_string (*; Switch.cut := 100*) diff --git a/compiler/core/j.ml b/compiler/core/j.ml index 638c59995df..0dc2e80dff8 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -148,9 +148,7 @@ and expression_desc = | Array of expression list | Optional_block of expression * bool (* [true] means [identity] *) - | Caml_block of expression list * mutable_flag * expression * tag_info - (* The third argument is [tag] , forth is [tag_info] *) - (* [tag] and [size] tailed for [Obj.new_block] *) + | Caml_block of expression list * mutable_flag * tag_info | Caml_block_tag of expression * string (* e.tag *) (* It will just fetch tag, to make it safe, when creating it, we need apply "|0", we don't do it in the diff --git a/compiler/core/js_analyzer.ml b/compiler/core/js_analyzer.ml index f0598e4ebd4..b7693f34e12 100644 --- a/compiler/core/js_analyzer.ml +++ b/compiler/core/js_analyzer.ml @@ -105,7 +105,7 @@ let rec no_side_effect_expression_desc (x : J.expression_desc) = no_side_effect a && no_side_effect b | Is_null_or_undefined b -> no_side_effect b | Str _ -> true - | Array xs | Caml_block (xs, _, _, _) -> + | Array xs | Caml_block (xs, _, _) -> (* create [immutable] block, does not really mean that this opreation itself is [pure]. @@ -239,10 +239,10 @@ let rec eq_expression ({expression_desc = x0} : J.expression) match y0 with | Optional_block (a1, b1) -> b0 = b1 && eq_expression a0 a1 | _ -> false) - | Caml_block (ls0, flag0, tag0, _) -> ( + | Caml_block (ls0, flag0, info0) -> ( match y0 with - | Caml_block (ls1, flag1, tag1, _) -> - eq_expression_list ls0 ls1 && flag0 = flag1 && eq_expression tag0 tag1 + | Caml_block (ls1, flag1, info1) -> + eq_expression_list ls0 ls1 && flag0 = flag1 && info0 = info1 | _ -> false) | Length _ | Is_null_or_undefined _ | String_append _ | Typeof _ | Js_not _ | Js_bnot _ | In _ | Cond _ | FlatCall _ | New _ | Fun _ | Raw_js_code _ @@ -312,7 +312,7 @@ let rev_toplevel_flatten block = | Str (b,_) -> b | Number _ -> true (* Can be refined later *) | Array xs -> Ext_list.for_all xs is_constant - | Caml_block(xs, Immutable, tag, _) + | Caml_block(xs, Immutable, _) -> Ext_list.for_all xs is_constant && is_constant tag | Bin (_op, a, b) -> is_constant a && is_constant b diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 1b2a17ad55b..4bef8c4a0f3 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -155,7 +155,6 @@ let rec exp_need_paren ?(arrow = false) (e : J.expression) = | Fun _ | Caml_block ( _, - _, _, ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ) ) @@ -588,7 +587,7 @@ and expression_desc cxt ~(level : int) f x : cxt = { expression_desc = (* This is the props javascript object *) - Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); + Caml_block (el, _mutable_flag, Lambda.Blk_record {fields}); }; ] -> (* We extract the props from the javascript object *) @@ -603,7 +602,7 @@ and expression_desc cxt ~(level : int) f x : cxt = tag; { expression_desc = - Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); + Caml_block (el, _mutable_flag, Lambda.Blk_record {fields}); }; key; ] -> @@ -937,14 +936,14 @@ and expression_desc cxt ~(level : int) f x : cxt = expression ~level cxt f (if identity then e else E.runtime_call Primitive_modules.option "some" [e]) - | Caml_block (el, _, _, Blk_module fields) -> + | Caml_block (el, _, Blk_module fields) -> expression_desc cxt ~level f (Object ( None, Ext_list.map_combine fields el (fun x -> Js_op.Lit (Ext_ident.convert x)) )) (*name convention of Record is slight different from modules*) - | Caml_block (el, _, _, Blk_record {fields}) -> + | Caml_block (el, _, Blk_record {fields}) -> if Array.length fields <> 0 && Ext_array.for_alli fields (fun i (v, _) -> string_of_int i = v) @@ -957,7 +956,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (Js_op.Lit f, x)) in expression_desc cxt ~level f (Object (None, fields)) - | Caml_block (el, _, _, Blk_poly_var _) -> ( + | Caml_block (el, _, Blk_poly_var _) -> ( match el with | [tag; value] -> expression_desc cxt ~level f @@ -968,19 +967,15 @@ and expression_desc cxt ~(level : int) f x : cxt = (Lit Literals.polyvar_value, value); ] )) | _ -> assert false) - | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> + | Caml_block (el, _, ((Blk_extension | Blk_record_ext _) as ext)) -> expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext) - | Caml_block (el, _, tag, Blk_record_inlined p) -> - let untagged = Ast_untagged_variants.process_untagged p.attrs in + | Caml_block (el, _, Blk_record_inlined p) -> + let {Ast_untagged_variants.tag; tag_name; untagged} = p.runtime in let objs = let tails = Ext_list.combine_array p.fields el (fun (i, opt) -> (Js_op.Lit i, opt)) in - let tag_name = - match Ast_untagged_variants.process_tag_name p.attrs with - | None -> L.tag - | Some s -> s - in + let tag_name = Option.value tag_name ~default:L.tag in let tails = Ext_list.filter_map tails (fun ((f, optional), x) -> match x.expression_desc with @@ -991,21 +986,17 @@ and expression_desc cxt ~(level : int) f x : cxt = else ( Js_op.Lit tag_name, (* TAG:xx for inline records *) - match Ast_untagged_variants.process_tag_type p.attrs with + match tag.tag_type with | None -> E.str p.name | Some t -> E.tag_type t ) :: tails in expression_desc cxt ~level f (Object (None, objs)) - | Caml_block (el, _, tag, Blk_constructor p) -> + | Caml_block (el, _, Blk_constructor p) -> let not_is_cons = p.name <> Literals.cons in - let tag_type = Ast_untagged_variants.process_tag_type p.attrs in - let untagged = Ast_untagged_variants.process_untagged p.attrs in - let tag_name = - match Ast_untagged_variants.process_tag_name p.attrs with - | None -> L.tag - | Some s -> s - in + let {Ast_untagged_variants.tag; tag_name; untagged} = p.runtime in + let tag_type = tag.tag_type in + let tag_name = Option.value tag_name ~default:L.tag in let objs = let tails = Ext_list.mapi_append el @@ -1036,11 +1027,9 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> J.Object (None, objs) in expression_desc cxt ~level f exp - | Caml_block (_, _, _, (Blk_module_export _ | Blk_some | Blk_some_not_nested)) - -> + | Caml_block (_, _, (Blk_module_export _ | Blk_some | Blk_some_not_nested)) -> assert false - | Caml_block (el, _, _tag, Blk_tuple) -> - expression_desc cxt ~level f (Array el) + | Caml_block (el, _, Blk_tuple) -> expression_desc cxt ~level f (Array el) | Caml_block_tag (e, tag) -> P.group f 1 (fun _ -> let cxt = expression ~level:15 cxt f e in @@ -1717,7 +1706,7 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt = | Throw e -> let e = match e.expression_desc with - | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> + | Caml_block (el, _, ((Blk_extension | Blk_record_ext _) as ext)) -> {e with expression_desc = exn_block_as_obj ~stack:true el ext} | _ -> e in diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index e63e974f63b..c158660a72d 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -202,7 +202,7 @@ let dot ?comment (e0 : t) (e1 : string) : t = let module_access (e : t) (name : string) (pos : int32) = let name = Ext_ident.convert name in match e.expression_desc with - | Caml_block (l, _, _, _) when no_side_effect e -> ( + | Caml_block (l, _, _) when no_side_effect e -> ( match Ext_list.nth_opt l (Int32.to_int pos) with | Some x -> x | None -> @@ -218,10 +218,10 @@ let module_access (e : t) (name : string) (pos : int32) = source_loc = None; } -let make_block ?comment (tag : t) (tag_info : J.tag_info) (es : t list) +let make_block ?comment (tag_info : J.tag_info) (es : t list) (mutable_flag : J.mutable_flag) : t = { - expression_desc = Caml_block (es, mutable_flag, tag, tag_info); + expression_desc = Caml_block (es, mutable_flag, tag_info); comment; source_loc = None; } @@ -478,7 +478,7 @@ let array_index ?comment (e0 : t) (e1 : t) : t = let array_index_by_int ?comment (e : t) (pos : int32) : t = match e.expression_desc with - | (Array l (* Float i -- should not appear here *) | Caml_block (l, _, _, _)) + | (Array l (* Float i -- should not appear here *) | Caml_block (l, _, _)) when no_side_effect e -> ( match Ext_list.nth_opt l (Int32.to_int pos) with | Some x -> x @@ -497,7 +497,7 @@ let array_index_by_int ?comment (e : t) (pos : int32) : t = let record_access (e : t) (name : string) (pos : int32) = match e.expression_desc with - | (Array l (* Float i -- should not appear here *) | Caml_block (l, _, _, _)) + | (Array l (* Float i -- should not appear here *) | Caml_block (l, _, _)) when no_side_effect e -> ( match Ext_list.nth_opt l (Int32.to_int pos) with | Some x -> x @@ -530,7 +530,7 @@ let cons_access (e : t) (pos : int32) = let poly_var_tag_access (e : t) = match e.expression_desc with - | Caml_block (l, _, _, _) when no_side_effect e -> ( + | Caml_block (l, _, _) when no_side_effect e -> ( match l with | x :: _ -> x | [] -> assert false) @@ -543,7 +543,7 @@ let poly_var_tag_access (e : t) = let poly_var_value_access (e : t) = match e.expression_desc with - | Caml_block (l, _, _, _) when no_side_effect e -> ( + | Caml_block (l, _, _) when no_side_effect e -> ( match l with | _ :: v :: _ -> v | _ -> assert false) @@ -556,7 +556,7 @@ let poly_var_value_access (e : t) = let extension_access (e : t) name (pos : int32) : t = match e.expression_desc with - | (Array l (* Float i -- should not appear here *) | Caml_block (l, _, _, _)) + | (Array l (* Float i -- should not appear here *) | Caml_block (l, _, _)) when no_side_effect e -> ( match Ext_list.nth_opt l (Int32.to_int pos) with | Some x -> x @@ -635,7 +635,7 @@ let extension_assign (e : t) (pos : int32) name (value : t) = let array_length ?comment (e : t) : t = match e.expression_desc with (* TODO: use array instead? *) - | (Array l | Caml_block (l, _, _, _)) when no_side_effect e -> + | (Array l | Caml_block (l, _, _)) when no_side_effect e -> int ?comment (Int32.of_int (List.length l)) | _ -> {expression_desc = Length e; comment; source_loc = None} diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index dad3c2daf2d..e0ac104a7f0 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -272,8 +272,6 @@ val optional_not_nest_block : J.expression -> J.expression val make_block : ?comment:string -> - J.expression -> - (* tag *) J.tag_info -> (* tag_info *) J.expression list -> diff --git a/compiler/core/js_of_lam_block.ml b/compiler/core/js_of_lam_block.ml index 19e75829973..82a4609a6f7 100644 --- a/compiler/core/js_of_lam_block.ml +++ b/compiler/core/js_of_lam_block.ml @@ -24,8 +24,8 @@ module E = Js_exp_make -let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args = - E.make_block tag tag_info args mutable_flag +let make_block mutable_flag (tag_info : Lam_tag_info.t) args = + E.make_block tag_info args mutable_flag let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = match field_info with diff --git a/compiler/core/js_of_lam_block.mli b/compiler/core/js_of_lam_block.mli index 4718461dfb6..4e1f0a86df1 100644 --- a/compiler/core/js_of_lam_block.mli +++ b/compiler/core/js_of_lam_block.mli @@ -25,11 +25,7 @@ (** Utilities for creating block of lambda expression in JS IR *) val make_block : - Js_op.mutable_flag -> - Lam_tag_info.t -> - J.expression -> - J.expression list -> - J.expression + Js_op.mutable_flag -> Lam_tag_info.t -> J.expression list -> J.expression val field : Lam_compat.field_dbg_info -> J.expression -> int32 -> J.expression diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index 8ae3c4b9ac4..11b7e3a2fb8 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -64,7 +64,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = let eval_as_event (arg : J.expression) (dispatches : (string * string) list option) = match arg.expression_desc with - | Caml_block ([{expression_desc = Str {txt}}; cb], _, _, Blk_poly_var _) + | Caml_block ([{expression_desc = Str {txt}}; cb], _, Blk_poly_var _) when Js_analyzer.no_side_effect_expression cb -> let v = match dispatches with @@ -123,5 +123,5 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t = let eval_as_unwrap (arg : J.expression) : E.t = match arg.expression_desc with - | Caml_block ([{expression_desc = Number _}; cb], _, _, _) -> cb + | Caml_block ([{expression_desc = Number _}; cb], _, _) -> cb | _ -> E.poly_var_value_access arg diff --git a/compiler/core/js_pass_flatten.ml b/compiler/core/js_pass_flatten.ml index c668d2be1b8..c22b4139d67 100644 --- a/compiler/core/js_pass_flatten.ml +++ b/compiler/core/js_pass_flatten.ml @@ -45,10 +45,7 @@ let flatten_map = (List.rev_map (fun x -> self.statement self x) (Js_analyzer.rev_flatten_seq v)) - | Exp - { - expression_desc = Caml_block (args, _mutable_flag, _tag, _tag_info); - } -> + | Exp {expression_desc = Caml_block (args, _mutable_flag, _tag_info)} -> S.block (Ext_list.map args (fun arg -> self.statement self (S.exp arg))) | Exp {expression_desc = Cond (a, b, c); comment; source_loc} -> diff --git a/compiler/core/js_pass_flatten_and_mark_dead.ml b/compiler/core/js_pass_flatten_and_mark_dead.ml index 22c0592e346..b108c765513 100644 --- a/compiler/core/js_pass_flatten_and_mark_dead.ml +++ b/compiler/core/js_pass_flatten_and_mark_dead.ml @@ -196,8 +196,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = Some ({ expression_desc = - Caml_block - ((_ :: _ :: _ as ls), Immutable, tag, tag_info); + Caml_block ((_ :: _ :: _ as ls), Immutable, tag_info); } as block); } as variable) -> ( (* If we do this, we should prevent incorrect inlning to inline it into an array :) @@ -235,7 +234,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = let e = { block with - expression_desc = Caml_block (List.rev e, Immutable, tag, tag_info); + expression_desc = Caml_block (List.rev e, Immutable, tag_info); } in let () = add_substitue substitution ident e in @@ -259,7 +258,7 @@ let subst_map (substitution : J.expression Hash_ident.t) = {expression_desc = Number (Int {i; _})} ) | Static_index ({expression_desc = Var (Id id)}, _, Some i) -> ( match Hash_ident.find_opt substitution id with - | Some {expression_desc = Caml_block (ls, Immutable, _, _)} -> ( + | Some {expression_desc = Caml_block (ls, Immutable, _)} -> ( (* user program can be wrong, we should not turn a runtime crash into compile time crash : ) *) diff --git a/compiler/core/js_record_fold.ml b/compiler/core/js_record_fold.ml index 359f81e4d30..d0ce36b202c 100644 --- a/compiler/core/js_record_fold.ml +++ b/compiler/core/js_record_fold.ml @@ -164,9 +164,8 @@ let expression_desc : 'a. ('a, expression_desc) fn = | Optional_block (_x0, _x1) -> let st = _self.expression _self st _x0 in st - | Caml_block (_x0, _x1, _x2, _x3) -> + | Caml_block (_x0, _x1, _x2) -> let st = list _self.expression _self st _x0 in - let st = _self.expression _self st _x2 in st | Caml_block_tag (_x0, _tag) -> let st = _self.expression _self st _x0 in diff --git a/compiler/core/js_record_iter.ml b/compiler/core/js_record_iter.ml index e836617d76a..985ce0823d9 100644 --- a/compiler/core/js_record_iter.ml +++ b/compiler/core/js_record_iter.ml @@ -129,9 +129,7 @@ let expression_desc : expression_desc fn = | Raw_js_code _ -> () | Array _x0 -> list _self.expression _self _x0 | Optional_block (_x0, _x1) -> _self.expression _self _x0 - | Caml_block (_x0, _x1, _x2, _x3) -> - list _self.expression _self _x0; - _self.expression _self _x2 + | Caml_block (_x0, _x1, _x2) -> list _self.expression _self _x0 | Caml_block_tag (_x0, _tag) -> _self.expression _self _x0 | Number _ -> () | Object (_x0, _x1) -> diff --git a/compiler/core/js_record_map.ml b/compiler/core/js_record_map.ml index 0ab675b3df1..3d2850bf0b2 100644 --- a/compiler/core/js_record_map.ml +++ b/compiler/core/js_record_map.ml @@ -169,10 +169,9 @@ let expression_desc : expression_desc fn = | Optional_block (_x0, _x1) -> let _x0 = _self.expression _self _x0 in Optional_block (_x0, _x1) - | Caml_block (_x0, _x1, _x2, _x3) -> + | Caml_block (_x0, _x1, _x2) -> let _x0 = list _self.expression _self _x0 in - let _x2 = _self.expression _self _x2 in - Caml_block (_x0, _x1, _x2, _x3) + Caml_block (_x0, _x1, _x2) | Caml_block_tag (_x0, tag) -> let _x0 = _self.expression _self _x0 in Caml_block_tag (_x0, tag) diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index a3c1e9d06c1..d2d4ca67610 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -32,15 +32,7 @@ type ap_info = { } module Types = struct - type lambda_switch = { - sw_consts_full: bool; - (* TODO: refine its representation *) - sw_consts: (int * t) list; - sw_blocks_full: bool; - sw_blocks: (int * t) list; - sw_failaction: t option; - sw_names: Ast_untagged_variants.switch_names option; - } + type lambda_switch = t Lambda.switch and lfunction = { arity: int; @@ -66,10 +58,13 @@ module Types = struct In most cases: {[ let sw = - {sw_consts_full = cstr.cstr_consts; sw_consts = consts; - sw_blocks_full = cstr.cstr_nonconsts; sw_blocks = nonconsts; + {sw_consts_full = List.length consts >= num_consts; + sw_consts = consts; + sw_blocks_full = List.length nonconsts >= num_nonconsts; + sw_blocks = nonconsts; sw_failaction = None} in ]} + where the counts come from the variant layout. but there are some edge cases (see https://caml.inria.fr/mantis/view.php?id=6033) one predicate used is @@ -274,17 +269,57 @@ and eq_option l1 l2 = and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx let switch lam (lam_switch : lambda_switch) : t = + let action_or_switch = function + | Some action -> action + | None -> ( + match lam_switch.sw_failaction with + | Some action -> action + | None -> Lswitch (lam, lam_switch)) + in match lam with - | Lconst (Const_int {i}) -> ( + | Lconst (Const_constructor cstr_name) -> + let action = + Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> + match key with + | Lambda.Switch_constructor (Constant tag) when cstr_name = tag -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | Lconst (Const_int {i; comment}) -> (* Because of inlining and dead code, we might be looking at a value of unexpected type e.g. an integer, so the const case might not be found *) - try - Ext_list.assoc_by_int lam_switch.sw_consts (Int32.to_int i) - lam_switch.sw_failaction - with _ -> Lswitch (lam, lam_switch)) - | Lconst (Const_block (i, _, _)) -> ( - try Ext_list.assoc_by_int lam_switch.sw_blocks i lam_switch.sw_failaction - with _ -> Lswitch (lam, lam_switch)) + let i = Int32.to_int i in + let action = + Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> + match key with + | Lambda.Switch_int ordinal when ordinal = i -> Some action + | Switch_constructor + (Constant {tag_type = Some (Ast_untagged_variants.Int value)}) + when comment = None && value = i -> + Some action + | Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action + | Lconst (Const_block (tag_info, _)) -> + let runtime = + match tag_info with + | Lambda.Blk_constructor {runtime} | Blk_record_inlined {runtime} -> + Some runtime + | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_record_ext _ + | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_some + | Blk_some_not_nested -> + None + in + let action = + Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> + match key with + | Switch_constructor (Block {runtime = case_runtime}) + when runtime = Some case_runtime -> + Some action + | Lambda.Switch_int _ | Switch_constructor _ -> None) + in + action_or_switch action | _ -> Lswitch (lam, lam_switch) let stringswitch (lam : t) cases default : t = @@ -374,6 +409,15 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | Ceq -> a = (b : string) | Cneq -> a <> b | _ -> assert false) + | ( Pintcomp ((Ceq | Cneq) as op), + Const_constructor {name = a; tag_type = None}, + Const_constructor {name = b; tag_type = None} ) -> + (* Both runtime representations are the constructor names *) + Lift.bool + (match op with + | Ceq -> a = b + | Cneq -> a <> b + | _ -> assert false) | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint | Pxorint | Plslint | Plsrint | Pasrint ), Const_int {i = aa}, @@ -411,7 +455,7 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = | _ -> default ()) | _ -> ( match prim with - | Pmakeblock (_size, Blk_module fields, _) -> ( + | Pmakeblock (Blk_module fields, _) -> ( let rec aux fields args (var : Ident.t) i = match (fields, args) with | [], [] -> true @@ -466,28 +510,42 @@ let has_boolean_type (x : t) = (** [complete_range sw_consts 0 7] is complete with [0,1,.. 7] *) -let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = +let rec complete_range (sw_consts : (Lambda.switch_key * _) list) ~(start : int) + ~finish = match sw_consts with | [] -> finish < start - | (i, _) :: rest -> + | (Switch_int i, _) :: rest -> start <= finish && i = start && complete_range rest ~start:(start + 1) ~finish + | (Switch_constructor _, _) :: _ -> false -let rec eval_const_as_bool (v : Lam_constant.t) : bool = +let rec eval_const_as_bool (v : Lam_constant.t) : bool option = match v with - | Const_int {i = x} -> x <> 0l - | Const_char x -> x <> 0 + | Const_int {i = x} -> Some (x <> 0l) + | Const_char x -> Some (x <> 0) | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ -> - false + Some false | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ | Const_bigint _ | Const_block _ -> - true + Some true | Const_some b -> eval_const_as_bool b + | Const_constructor {name; tag_type} -> ( + (* Truthiness of the canonical runtime representation *) + match tag_type with + | None -> Some (name <> "[]") (* the name string; [] is the number 0 *) + | Some (String s) -> Some (s <> "") + | Some (Int i) -> Some (i <> 0) + | Some (Bool b) -> Some b + | Some Null | Some Undefined -> Some false + | Some (Float _ | BigInt _ | Untagged _) -> None) let if_ (a : t) (b : t) (c : t) : t = match a with - | Lconst v -> if eval_const_as_bool v then b else c + | Lconst v -> ( + match eval_const_as_bool v with + | Some v -> if v then b else c + | None -> Lifthenelse (a, b, c)) | _ -> ( match (b, c) with | _, Lconst (Const_int {comment = Pt_assertfalse}) -> diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index dbd026c6fd1..5aef785c8be 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -32,14 +32,7 @@ type ap_info = { type ident = Ident.t -type lambda_switch = { - sw_consts_full: bool; - sw_consts: (int * t) list; - sw_blocks_full: bool; - sw_blocks: (int * t) list; - sw_failaction: t option; - sw_names: Ast_untagged_variants.switch_names option; -} +type lambda_switch = t Lambda.switch and apply = private { ap_func: t; diff --git a/compiler/core/lam_analysis.ml b/compiler/core/lam_analysis.ml index d8cd3095328..c711e88ba57 100644 --- a/compiler/core/lam_analysis.ml +++ b/compiler/core/lam_analysis.ml @@ -191,13 +191,13 @@ let rec size (lam : Lam.t) = and size_constant x = match x with - | Const_int _ | Const_char _ | Const_float _ | Const_bigint _ - | Const_pointer _ | Const_js_null | Const_js_undefined _ | Const_module_alias - | Const_js_true | Const_js_false -> + | Const_int _ | Const_constructor _ | Const_char _ | Const_float _ + | Const_bigint _ | Const_pointer _ | Const_js_null | Const_js_undefined _ + | Const_module_alias | Const_js_true | Const_js_false -> 1 | Const_string _ -> 1 | Const_some s -> size_constant s - | Const_block (_, _, str) -> + | Const_block (_, str) -> Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) and size_lams acc (lams : Lam.t list) = @@ -267,8 +267,7 @@ let safe_to_inline (lam : Lam.t) = match lam with | Lfunction _ -> true | Lconst - ( Const_pointer _ - | Const_int {comment = Pt_constructor _} - | Const_js_true | Const_js_false | Const_js_undefined _ ) -> + ( Const_pointer _ | Const_constructor _ | Const_js_true | Const_js_false + | Const_js_undefined _ ) -> true | _ -> false diff --git a/compiler/core/lam_beta_reduce.ml b/compiler/core/lam_beta_reduce.ml index 10ddae76b68..ed930c68eab 100644 --- a/compiler/core/lam_beta_reduce.ml +++ b/compiler/core/lam_beta_reduce.ml @@ -68,7 +68,7 @@ let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) order. *) Ext_list.fold_left rest_bindings new_body (fun l (param, arg) -> (match arg with - | Lprim {primitive = Pmakeblock (_, _, Immutable); args; _} -> + | Lprim {primitive = Pmakeblock (_, Immutable); args; _} -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]; _} -> @@ -110,7 +110,7 @@ let propagate_beta_reduce_with_map (meta : Lam_stats.t) (* See above: fold left so arguments evaluate in call order. *) Ext_list.fold_left rest_bindings new_body (fun l (param, (arg : Lam.t)) -> (match arg with - | Lprim {primitive = Pmakeblock (_, _, Immutable); args} -> + | Lprim {primitive = Pmakeblock (_, Immutable); args} -> Hash_ident.replace meta.ident_tbl param (Lam_util.kind_of_lambda_block args) | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 597a638b770..64aa2caf845 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -130,7 +130,7 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = sw_blocks; sw_blocks_full; sw_consts_full; - sw_names; + sw_dispatch; } ) -> let l = aux l in Lam.switch l @@ -140,7 +140,7 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_blocks_full; sw_failaction = option_map sw_failaction; - sw_names; + sw_dispatch; } | Lstringswitch (l, sw, d) -> let l = aux l in diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index dfb703f37d5..1fc62503cdf 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -199,60 +199,36 @@ let default_action ~saturated failaction = | None -> Complete | Some x -> if saturated then Complete else Default x -let get_const_tag i (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with - | None -> None - | Some {consts} -> Some consts.(i) - -let get_block i (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with - | None -> None - | Some {blocks} -> Some blocks.(i) - -let get_tag_name (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with - | None -> Js_dump_lit.tag - | Some {blocks} -> ( - match - Array.find_opt - (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) - blocks - with - | Some {tag_name = Some s} -> s - | _ -> Js_dump_lit.tag) - -let get_block_cases (sw_names : Ast_untagged_variants.switch_names option) = - let res = ref [] in - (match sw_names with - | None -> res := [] - | Some {blocks} -> - Ext_array.iter blocks (function - | {block_type = Some block_type} -> res := block_type :: !res - | {block_type = None} -> ())); - !res - -let get_literal_cases (sw_names : Ast_untagged_variants.switch_names option) = - let res = ref [] in - (match sw_names with - | None -> res := [] - | Some {consts} -> - Ext_array.iter consts (function - | {tag_type = Some t} -> res := t :: !res - | {name; tag_type = None} -> res := String name :: !res)); - !res +let tag_of_switch_key = function + | Lambda.Switch_int _ -> None + | Switch_constructor (Constant tag) -> Some tag + | Switch_constructor + (Block + { + runtime = {tag = {name}; untagged = true}; + block_type = Some block_type; + }) -> + Some {name; tag_type = Some (Untagged block_type)} + | Switch_constructor (Block {runtime = {untagged = false; tag}}) -> Some tag + | Switch_constructor (Block {runtime = {untagged = true}; block_type = None}) + -> + assert false -let has_null_undefined_other - (sw_names : Ast_untagged_variants.switch_names option) = - let null, undefined, other = (ref false, ref false, ref false) in - (match sw_names with - | None -> () - | Some {consts; blocks} -> - Ext_array.iter consts (fun x -> - match x.tag_type with - | Some Undefined -> undefined := true - | Some Null -> null := true - | _ -> other := true)); - (!null, !undefined, !other) +let dispatch_info = function + | Lambda.Switch_direct -> (Js_dump_lit.tag, [], [], (false, false, false)) + | Switch_variant + { + Ast_untagged_variants.tag_name; + block_types; + literal_tags; + has_null; + has_undefined; + has_other_literal; + } -> + ( Option.value tag_name ~default:Js_dump_lit.tag, + block_types, + literal_tags, + (has_null, has_undefined, has_other_literal) ) let no_effects_const = lazy true (* let has_effects_const = lazy false *) @@ -456,7 +432,7 @@ let compile output_prefix = result ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), [] ) - | Lprim {primitive = Pmakeblock (_, _, _); args} + | Lprim {primitive = Pmakeblock (_, _); args} when args_either_function_or_const args -> (compile_lambda {cxt with continuation = Declare (Alias, id)} arg, []) (* case of lazy blocks, treat it as usual *) @@ -464,8 +440,7 @@ let compile output_prefix = { primitive = Pmakeblock - ( _, - (( Blk_record _ + ( (( Blk_record _ | Blk_constructor {num_nonconst = 1} | Blk_record_inlined {num_nonconst = 1} ) as tag_info), _ ); @@ -509,7 +484,7 @@ let compile output_prefix = | Lconst x -> Lam_compile_const.translate x | _ -> assert false)))), [] ) - | Lprim {primitive = Pmakeblock (_, tag_info, _)} -> ( + | Lprim {primitive = Pmakeblock (tag_info, _)} -> ( (* Lconst should not appear here if we do [scc] optimization, since it's faked recursive value, however it would affect scope issues, we have to declare it first @@ -711,11 +686,10 @@ let compile output_prefix = in [switch ?default ?declaration switch_exp body]) - and use_compile_literal_cases table - ~(get_tag : _ -> Ast_untagged_variants.tag option) = + and use_compile_literal_cases table = List.fold_right - (fun (i, lam) acc -> - match (get_tag i, acc) with + (fun (key, lam) acc -> + match (tag_of_switch_key key, acc) with | Some {Ast_untagged_variants.tag_type = Some t}, Some string_table -> Some ((t, lam) :: string_table) | Some {name; tag_type = None}, Some string_table -> @@ -723,9 +697,9 @@ let compile output_prefix = | _, _ -> None) table (Some []) and compile_cases ?(untagged = false) ?(has_null_case = false) ~cxt - ~(switch_exp : E.t) ?(default = NonComplete) ?(get_tag = fun _ -> None) - ?(block_cases = []) cases : initialization = - match use_compile_literal_cases cases ~get_tag with + ~(switch_exp : E.t) ?(default = NonComplete) ?(block_cases = []) cases : + initialization = + match use_compile_literal_cases cases with | Some string_cases -> if untagged then compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default @@ -734,15 +708,19 @@ let compile output_prefix = | None -> cases |> compile_general_cases - ~make_exp:(fun i -> - match get_tag i with - | None -> E.small_int i - | Some {tag_type = Some (String s)} -> E.str s - | Some {name} -> E.str name) + ~make_exp:(function + | Lambda.Switch_int i -> E.small_int i + | Switch_constructor _ -> assert false) ~eq_exp:(fun _ x _ y -> E.int_equal x y) ~cxt ~switch:(fun ?default ?declaration e clauses -> - S.int_switch ?default ?declaration e clauses) + S.int_switch ?default ?declaration e + (List.map + (fun (key, clause) -> + match key with + | Lambda.Switch_int i -> (i, clause) + | Switch_constructor _ -> assert false) + clauses)) ~switch_exp ~default and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) (lambda_cxt : Lam_compile_context.t) = @@ -759,7 +737,7 @@ let compile output_prefix = sw_blocks_full; sw_blocks; sw_failaction; - sw_names; + sw_dispatch; } : Lam.lambda_switch) = sw @@ -770,19 +748,9 @@ let compile output_prefix = let sw_blocks_default = default_action ~saturated:sw_blocks_full sw_failaction in - let get_const_tag i = get_const_tag i sw_names in - let get_block i = get_block i sw_names in - let block_cases = get_block_cases sw_names in - let get_block_tag i : Ast_untagged_variants.tag option = - match get_block i with - | None -> None - | Some {tag = {name}; block_type = Some block_type} -> - Some {name; tag_type = Some (Untagged block_type)} (* untagged block *) - | Some {block_type = None; tag} -> - (* tagged block *) - Some tag + let tag_name, block_cases, literal_cases, has_null_undefined_other = + dispatch_info sw_dispatch in - let tag_name = get_tag_name sw_names in let untagged = block_cases <> [] in let compile_whole (cxt : Lam_compile_context.t) = match @@ -795,22 +763,16 @@ let compile output_prefix = if sw_consts_full && sw_consts = [] then compile_cases ~block_cases ~untagged ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~default:sw_blocks_default ~get_tag:get_block_tag sw_blocks + ~default:sw_blocks_default sw_blocks else if sw_blocks_full && sw_blocks = [] then compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default - ~get_tag:get_const_tag sw_consts + sw_consts else (* [e] will be used twice *) let dispatch e = let is_a_literal_case () = - if untagged then - E.is_a_literal_case - ~literal_cases:(get_literal_cases sw_names) - ~block_cases e - else - E.is_int_tag - ~has_null_undefined_other:(has_null_undefined_other sw_names) - e + if untagged then E.is_a_literal_case ~literal_cases ~block_cases e + else E.is_int_tag ~has_null_undefined_other e in let eq_default d1 d2 = match (d1, d2) with @@ -824,25 +786,22 @@ let compile output_prefix = && List.length sw_consts = 0 && eq_default sw_num_default sw_blocks_default then - let literal_cases = get_literal_cases sw_names in let has_null_case = List.mem Ast_untagged_variants.Null literal_cases in compile_cases ~untagged ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~block_cases ~has_null_case ~default:sw_blocks_default - ~get_tag:get_block_tag sw_blocks + ~block_cases ~has_null_case ~default:sw_blocks_default sw_blocks else [ S.if_ (is_a_literal_case ()) (compile_cases ~cxt ~switch_exp:e ~block_cases - ~default:sw_num_default ~get_tag:get_const_tag sw_consts) + ~default:sw_num_default sw_consts) ~else_: (compile_cases ~untagged ~cxt ~switch_exp: (if untagged then e else E.tag ~name:tag_name e) - ~block_cases ~default:sw_blocks_default - ~get_tag:get_block_tag sw_blocks); + ~block_cases ~default:sw_blocks_default sw_blocks); ] in match e.expression_desc with @@ -1091,6 +1050,9 @@ let compile output_prefix = let jmp_table, handlers = Lam_compile_context.add_jmps lambda_cxt.jmp_table exit_id code_table in + let handlers = + List.map (fun (i, handler) -> (Lambda.Switch_int i, handler)) handlers + in (* Declaration First, body and handler have the same value *) let declares = diff --git a/compiler/core/lam_compile_const.ml b/compiler/core/lam_compile_const.ml index 4b50f55618d..e30c0423b2b 100644 --- a/compiler/core/lam_compile_const.ml +++ b/compiler/core/lam_compile_const.ml @@ -50,12 +50,11 @@ and translate (x : Lam_constant.t) : J.expression = | Const_js_null -> E.nil | Const_js_undefined {is_unit = true} -> E.unit | Const_js_undefined {is_unit = false} -> E.undefined - | Const_int - {i; comment = Pt_constructor {cstr_name = {name; tag_type = None}}} - when name <> "[]" -> - E.str name - | Const_int {i; comment = Pt_constructor {cstr_name = {tag_type = Some t}}} -> - E.tag_type t + | Const_constructor {name; tag_type = None} -> + (* The runtime representation of a constant constructor is its name, + except for the list constructor [] which is the number 0 *) + if name = "[]" then E.int 0l ~comment:"[]" else E.str name + | Const_constructor {tag_type = Some t} -> E.tag_type t | Const_int {i; comment} -> E.int i ?comment:(Lam_constant.string_of_pointer_info comment) | Const_char i -> Js_of_lam_string.const_char i @@ -64,9 +63,8 @@ and translate (x : Lam_constant.t) : J.expression = | Const_string {s; delim = None | Some DNoQuotes} -> E.str s | Const_string {s; delim = Some delim} -> E.str ~delim s | Const_pointer name -> E.str name - | Const_block (tag, tag_info, xs) -> - Js_of_lam_block.make_block NA tag_info (E.small_int tag) - (Ext_list.map xs translate) + | Const_block (tag_info, xs) -> + Js_of_lam_block.make_block NA tag_info (Ext_list.map xs translate) (* E.arr Mutable ~comment:"float array" *) (* (Ext_list.map (fun x -> E.float x ) ars) *) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 17ef67d9527..9563b643292 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -174,11 +174,11 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) E.optional_not_nest_block arg | _ -> E.optional_block arg) | Psome_not_nest -> E.optional_not_nest_block (Ext_list.singleton_exn args) - | Pmakeblock (tag, tag_info, mutable_flag) -> + | Pmakeblock (tag_info, mutable_flag) -> (* RUNTIME *) Js_of_lam_block.make_block (Js_op_util.of_lam_mutable_flag mutable_flag) - tag_info (E.small_int tag) args + tag_info args | Pval_from_option -> Js_of_lam_option.val_from_option (Ext_list.singleton_exn args) | Pval_from_option_not_nest -> Ext_list.singleton_exn args @@ -571,8 +571,13 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Pmakelist -> Js_of_lam_block.make_block (Js_op_util.of_lam_mutable_flag Mutable) - (Blk_constructor {name = "::"; num_nonconst = 1; tag = 0; attrs = []}) - (E.small_int 0) args + (Blk_constructor + { + name = "::"; + num_nonconst = 1; + runtime = Ast_untagged_variants.block_runtime ~name:"::" []; + }) + args | Pmakedict -> ( match args with | [{expression_desc = Array items}] -> @@ -580,7 +585,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) (items |> List.filter_map (fun (exp : J.expression) -> match exp.expression_desc with - | Caml_block ([{expression_desc = Str {txt}}; expr], _, _, _) -> + | Caml_block ([{expression_desc = Str {txt}}; expr], _, _) -> Some (Js_op.Lit txt, expr) | _ -> None)) | _ -> assert false) diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index a5764124949..c91c3a57e73 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -33,35 +33,26 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = | Const_base (Const_int32 i) -> Const_int {i; comment = None} | Const_base (Const_int64 _) -> assert false | Const_base (Const_bigint (sign, i)) -> Const_bigint (sign, i) - | Const_pointer (0, Pt_constructor {name = "()"; const = 1; non_const = 0}) -> + | Const_pointer (Pt_constructor {name = "()"}) -> Const_js_undefined {is_unit = true} | Const_false -> Const_js_false | Const_true -> Const_js_true - | Const_pointer (i, p) -> ( + | Const_pointer p -> ( match p with | Pt_module_alias -> Const_module_alias | Pt_shape_none -> Lam_constant.lam_none - | Pt_assertfalse -> Const_int {i = Int32.of_int i; comment = Pt_assertfalse} - | Pt_constructor {name; const; non_const; attrs} -> - let tag_type = Ast_untagged_variants.process_tag_type attrs in - let i = - match tag_type with - | Some (Ast_untagged_variants.Int v) -> v - | _ -> i - in - Const_int - { - i = Int32.of_int i; - comment = - Pt_constructor {cstr_name = {name; tag_type}; const; non_const}; - } + | Pt_assertfalse -> Const_int {i = 0l; comment = Pt_assertfalse} + | Pt_constructor {tag_type = Some (Ast_untagged_variants.Int v)} -> + (* A constructor represented as a number is a genuine number at + runtime; folding relies on it being an ordinary int constant *) + Const_int {i = Int32.of_int v; comment = None} + | Pt_constructor runtime -> Const_constructor runtime | Pt_variant {name} -> if Ext_string.is_valid_hash_number name then Const_int {i = Ext_string.hash_number_as_i32_exn name; comment = None} else Const_pointer name) | Const_immstring s -> Const_string {s; delim = None} | Const_block (t, xs) -> ( - let tag = Lambda.tag_of_tag_info t in match t with | Blk_some_not_nested -> Const_some (convert_constant (Ext_list.singleton_exn xs)) @@ -69,7 +60,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_inlined _ | Blk_record_ext _ -> - Const_block (tag, t, Ext_list.map xs convert_constant) + Const_block (t, Ext_list.map xs convert_constant) | Blk_poly_var s -> ( match xs with | [_; value] -> @@ -78,5 +69,5 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = Const_int {i = Ext_string.hash_number_as_i32_exn s; comment = None} else Const_string {s; delim = None} in - Const_block (tag, t, [tag_val; convert_constant value]) + Const_block (t, [tag_val; convert_constant value]) | _ -> assert false)) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index fe248d849e6..2c38ab85190 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -117,20 +117,20 @@ let lam_is_var (x : Lam.t) (y : Ident.t) = (** Make sure no int range overflow happens also we only check [int] *) -let happens_to_be_diff (sw_consts : (int * Lambda.lambda) list) sw_names : +let happens_to_be_diff (sw_consts : (Lambda.switch_key * Lambda.lambda) list) : int option = match sw_consts with - | (a, Lconst (Const_base (Const_int a0))) - :: (b, Lconst (Const_base (Const_int b0))) + | (Switch_int a, Lconst (Const_base (Const_int a0))) + :: (Switch_int b, Lconst (Const_base (Const_int b0))) :: rest - when sw_names = None && no_over_flow a && no_over_flow a0 && no_over_flow b - && no_over_flow b0 -> + when no_over_flow a && no_over_flow a0 && no_over_flow b && no_over_flow b0 + -> let diff = a0 - a in if b0 - b = diff then if - Ext_list.for_all rest (fun (x, lam) -> - match lam with - | Lconst (Const_base (Const_int x0)) + Ext_list.for_all rest (fun (key, lam) -> + match (key, lam) with + | Switch_int x, Lconst (Const_base (Const_int x0)) when no_over_flow x0 && no_over_flow x -> x0 - x = diff | _ -> false) @@ -172,14 +172,13 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = seq (Ext_list.singleton_exn args) unit | Pgetglobal _ -> assert false | Pmakeblock info -> ( - let tag = Lambda.tag_of_tag_info info in let mutable_flag = Lambda.mutable_flag_of_tag_info info in match info with | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc | Blk_some -> prim ~primitive:Psome ~args loc | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ -> - prim ~primitive:(Pmakeblock (tag, info, mutable_flag)) ~args loc + prim ~primitive:(Pmakeblock (info, mutable_flag)) ~args loc | Blk_poly_var s -> ( match args with | [_; value] -> @@ -189,7 +188,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = else Const_string {s; delim = None} in prim - ~primitive:(Pmakeblock (tag, info, mutable_flag)) + ~primitive:(Pmakeblock (info, mutable_flag)) ~args:[Lam.const tag_val; value] loc | _ -> assert false)) @@ -301,11 +300,11 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pimport -> prim ~primitive:Pimport ~args loc | Pinit_mod -> ( match args with - | [_loc; Lconst (Const_block (0, _, [Const_block (0, _, [])]))] -> Lam.unit + | [_loc; Lconst (Const_block (_, [Const_block (_, [])]))] -> Lam.unit | _ -> prim ~primitive:Pinit_mod ~args loc) | Pupdate_mod -> ( match args with - | [Lconst (Const_block (0, _, [Const_block (0, _, [])])); _; _] -> Lam.unit + | [Lconst (Const_block (_, [Const_block (_, [])])); _; _] -> Lam.unit | _ -> prim ~primitive:Pupdate_mod ~args loc) | Phash -> prim ~primitive:Phash ~args loc | Phash_mixint -> prim ~primitive:Phash_mixint ~args loc @@ -569,7 +568,10 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : { px with sw_consts = - Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); + Ext_list.map sw_consts (fun (key, act) -> + match key with + | Lambda.Switch_int i -> (Lambda.Switch_int (i - offset), act) + | Lambda.Switch_constructor _ -> assert false); } | _ -> Lam.let_ kind id new_e new_body) and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = @@ -618,12 +620,12 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | { sw_failaction = None; sw_blocks = []; - sw_numblocks = 0; + sw_blocks_full = true; sw_consts; - sw_numconsts; - sw_names; + sw_consts_full; + sw_dispatch; } -> ( - match happens_to_be_diff sw_consts sw_names with + match happens_to_be_diff sw_consts with | Some 0 -> e | Some i -> prim ~primitive:Paddint @@ -636,18 +638,18 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : sw_blocks = []; sw_blocks_full = true; sw_consts = Ext_list.map_snd sw_consts convert_aux; - sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; - sw_names = s.sw_names; + sw_consts_full; + sw_dispatch; }) | _ -> Lam.switch e { - sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; + sw_consts_full = s.sw_consts_full; sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; + sw_blocks_full = s.sw_blocks_full; sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; sw_failaction = Ext_option.map s.sw_failaction convert_aux; - sw_names = s.sw_names; + sw_dispatch = s.sw_dispatch; } in (convert_aux lam, may_depends) diff --git a/compiler/core/lam_eta_conversion.ml b/compiler/core/lam_eta_conversion.ml index 058af703b82..4e2e61c18a4 100644 --- a/compiler/core/lam_eta_conversion.ml +++ b/compiler/core/lam_eta_conversion.ml @@ -42,9 +42,9 @@ let transform_under_supply n ap_info fn args = match lam with | Lvar _ | Lconst - ( Const_int _ | Const_char _ | Const_string _ | Const_float _ - | Const_bigint _ | Const_pointer _ | Const_js_true | Const_js_false - | Const_js_undefined _ ) + ( Const_int _ | Const_constructor _ | Const_char _ | Const_string _ + | Const_float _ | Const_bigint _ | Const_pointer _ | Const_js_true + | Const_js_false | Const_js_undefined _ ) | Lprim {primitive = Pfield (_, Fld_module _); _} | Lfunction _ -> (lam :: acc, bind) diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index e8ec2a51b12..b83e930bb33 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -77,7 +77,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_blocks; sw_blocks_full; sw_consts_full; - sw_names; + sw_dispatch; } ) -> Lam.switch (simpl l) { @@ -86,7 +86,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_blocks_full; sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; + sw_dispatch; } | Lstringswitch (l, sw, d) -> Lam.stringswitch (simpl l) diff --git a/compiler/core/lam_pass_collect.ml b/compiler/core/lam_pass_collect.ml index 807e9323f3b..f9ea6a7c188 100644 --- a/compiler/core/lam_pass_collect.ml +++ b/compiler/core/lam_pass_collect.ml @@ -58,7 +58,7 @@ let collect_info (meta : Lam_stats.t) (lam : Lam.t) = let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = match lam with | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) - | Lprim {primitive = Pmakeblock (_, _, Immutable); args = ls} -> + | Lprim {primitive = Pmakeblock (_, Immutable); args = ls} -> Hash_ident.replace meta.ident_tbl ident (Lam_util.kind_of_lambda_block ls); List.iter collect ls | Lprim {primitive = Psome | Psome_not_nest; args = [v]} -> diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index db4de083e93..efe7625838e 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -121,7 +121,7 @@ let rec rhs_is_beta_residue (lam : Lam.t) = | Llet ( (Alias | Strict | StrictOpt), _, - (Lprim {primitive = Pmakeblock (_, _, Immutable)} | Lvar _), + (Lprim {primitive = Pmakeblock (_, Immutable)} | Lvar _), rest ) -> rhs_is_beta_residue rest | Lapply _ -> true @@ -177,7 +177,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = match (id.name, str, res) with | ( ("match" | "include" | "param"), (Alias | Strict | StrictOpt), - Lprim {primitive = Pmakeblock (_, _, Immutable); args} ) -> ( + Lprim {primitive = Pmakeblock (_, Immutable); args} ) -> ( match eliminate_tuple id body Map_int.empty with | Some (tuple_mapping, body) -> flatten @@ -259,7 +259,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_blocks; sw_blocks_full; sw_consts_full; - sw_names; + sw_dispatch; } ) -> Lam.switch (aux l) { @@ -268,7 +268,7 @@ let deep_flatten (lam : Lam.t) : Lam.t = sw_consts_full; sw_blocks_full; sw_failaction = Ext_option.map sw_failaction aux; - sw_names; + sw_dispatch; } | Lstringswitch (l, sw, d) -> Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) (Ext_option.map d aux) diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 030f0c54f10..3f1ef7d441a 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -78,7 +78,7 @@ let rec eliminate_ref id (lam : Lam.t) = (match sw.sw_failaction with | None -> None | Some x -> Some (eliminate_ref id x)); - sw_names = sw.sw_names; + sw_dispatch = sw.sw_dispatch; } | Lstringswitch (e, sw, default) -> Lam.stringswitch (eliminate_ref id e) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index e662b7ecb4b..f0e5f2f5ba0 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -26,7 +26,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = v, Lprim { - primitive = Pmakeblock (0, _, Mutable) as primitive; + primitive = Pmakeblock (_, Mutable) as primitive; args = [linit]; loc; }, @@ -51,9 +51,10 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = | {times = 1; captured = true}, (Lconst _ | Lvar _) | ( _, ( Lconst - ( Const_int _ | Const_char _ | Const_float _ | Const_bigint _ - | Const_pointer _ | Const_js_true | Const_js_false - | Const_js_undefined _ ) (* could be poly-variant [`A] -> [65a]*) + ( Const_int _ | Const_constructor _ | Const_char _ | Const_float _ + | Const_bigint _ | Const_pointer _ | Const_js_true + | Const_js_false | Const_js_undefined _ ) + (* could be poly-variant [`A] -> [65a]*) | Lprim {primitive = Pfield _; args = [Lglobal_module _]} ) ) (* Const_int64 is no longer primitive Note for some constant which is not @@ -95,7 +96,7 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = match l1 with | Lprim { - primitive = Pmakeblock (0, _, Mutable) as primitive; + primitive = Pmakeblock (_, Mutable) as primitive; args = [linit]; loc; } -> ( diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index c6b10824ad3..83247e64156 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -44,7 +44,7 @@ let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = let is_const_some (cst : Lam_constant.t) : bool = match cst with | Const_some _ -> true - | Const_block (_, (Lambda.Blk_some | Lambda.Blk_some_not_nested), _) -> true + | Const_block ((Lambda.Blk_some | Lambda.Blk_some_not_nested), _) -> true | _ -> false let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = @@ -254,7 +254,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_blocks; sw_blocks_full; sw_consts_full; - sw_names; + sw_dispatch; } ) -> Lam.switch (simpl l) { @@ -263,7 +263,7 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = sw_consts_full; sw_blocks_full; sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; + sw_dispatch; } | Lstringswitch (l, sw, d) -> let l = diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index a1ea361b259..65c04a2ce4f 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -26,16 +26,9 @@ type ident = Ident.t -type record_representation = - | Record_regular - | Record_inlined of {tag: int; name: string; num_nonconsts: int} - (* Inlined record *) - | Record_extension -(* Inlined record under extension *) - type t = (* Operations on heap blocks *) - | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag + | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag | Pfield of int * Lam_compat.field_dbg_info | Psetfield of int * Lam_compat.set_field_dbg_info (* could have field info at least for record *) @@ -251,10 +244,9 @@ let eq_primitive_approx (lhs : t) (rhs : t) = match rhs with | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 | _ -> false) - | Pmakeblock (i0, info0, flag0) -> ( + | Pmakeblock (info0, flag0) -> ( match rhs with - | Pmakeblock (i1, info1, flag1) -> - i0 = i1 && flag0 = flag1 && eq_tag_info info0 info1 + | Pmakeblock (info1, flag1) -> flag0 = flag1 && eq_tag_info info0 info1 | _ -> false) | Pjs_call {prim_name; arg_types; ffi; dynamic_import; _} -> ( match rhs with diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 238045e9f4c..989cd79e322 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -24,15 +24,8 @@ type ident = Ident.t -type record_representation = - | Record_regular - | Record_inlined of {tag: int; name: string; num_nonconsts: int} - (* Inlined record *) - | Record_extension -(* Inlined record under extension *) - type t = - | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag + | Pmakeblock of Lam_tag_info.t * Asttypes.mutable_flag | Pfield of int * Lambda.field_dbg_info | Psetfield of int * Lambda.set_field_dbg_info | Pduprecord diff --git a/compiler/core/lam_print.ml b/compiler/core/lam_print.ml index dd692e8842a..4fecbbc3db8 100644 --- a/compiler/core/lam_print.ml +++ b/compiler/core/lam_print.ml @@ -26,13 +26,16 @@ let rec struct_const ppf (cst : Lam_constant.t) = | Const_float f -> fprintf ppf "%s" f | Const_bigint (sign, i) -> fprintf ppf "%sn" (Bigint_utils.to_string sign i) | Const_pointer name -> fprintf ppf "`%s" name + | Const_constructor {name} -> fprintf ppf "`%s" name | Const_some n -> fprintf ppf "[some-c]%a" struct_const n - | Const_block (tag, _, []) -> fprintf ppf "[%i]" tag - | Const_block (tag, _, sc1 :: scl) -> + | Const_block (i, []) -> fprintf ppf "[%s]" (Lambda.tag_label_of_tag_info i) + | Const_block (i, sc1 :: scl) -> let sconsts ppf scl = List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + fprintf ppf "@[<1>[%s:@ @[%a%a@]]@]" + (Lambda.tag_label_of_tag_info i) + struct_const sc1 sconsts scl (* let string_of_loc_kind (loc : Lambda.loc_kind) = match loc with @@ -71,8 +74,10 @@ let primitive ppf (prim : Lam_primitive.t) = | Pis_undefined -> fprintf ppf "[?undefined]" | Pis_null_undefined -> fprintf ppf "[?null?undefined]" | Pimport -> fprintf ppf "[import]" - | Pmakeblock (tag, _, Immutable) -> fprintf ppf "makeblock %i" tag - | Pmakeblock (tag, _, Mutable) -> fprintf ppf "makemutable %i" tag + | Pmakeblock (i, Immutable) -> + fprintf ppf "makeblock %s" (Lambda.tag_label_of_tag_info i) + | Pmakeblock (i, Mutable) -> + fprintf ppf "makemutable %s" (Lambda.tag_label_of_tag_info i) | Pfield (n, field_info) -> ( match Lam_compat.str_of_field_info field_info with | None -> fprintf ppf "field %i" n @@ -314,22 +319,24 @@ let lambda ppf v = let switch ppf (sw : Lam.lambda_switch) = let spc = ref false in List.iter - (fun (n, l) -> + (fun (key, l) -> if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i %S:@ %a@]" n - (match sw.sw_names with - | None -> "" - | Some x -> x.consts.(n).name) - lam l) + match key with + | Lambda.Switch_int ordinal -> + fprintf ppf "@[case int %i:@ %a@]" ordinal lam l + | Lambda.Switch_constructor (Constant {name}) -> + fprintf ppf "@[case constructor %S:@ %a@]" name lam l + | Lambda.Switch_constructor (Block _) -> assert false) sw.sw_consts; List.iter - (fun (n, l) -> + (fun (key, l) -> if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i %S:@ %a@]" n - (match sw.sw_names with - | None -> "" - | Some x -> x.blocks.(n).tag.name) - lam l) + match key with + | Lambda.Switch_int ordinal -> + fprintf ppf "@[case tag %i:@ %a@]" ordinal lam l + | Lambda.Switch_constructor (Block {runtime = {tag = {name}}}) -> + fprintf ppf "@[case constructor %S:@ %a@]" name lam l + | Lambda.Switch_constructor (Constant _) -> assert false) sw.sw_blocks; match sw.sw_failaction with | None -> () @@ -431,7 +438,7 @@ let lambda ppf v = (* -> *) begin match flat [] lam with - | (Nop, Lprim {primitive = Pmakeblock (_, _, _); args = toplevels; _}) + | (Nop, Lprim {primitive = Pmakeblock (_, _); args = toplevels; _}) :: rest -> (* let spc = ref false in *) List.iter diff --git a/compiler/core/lam_stats_export.ml b/compiler/core/lam_stats_export.ml index 711ab5be42f..3e9f8239c31 100644 --- a/compiler/core/lam_stats_export.ml +++ b/compiler/core/lam_stats_export.ml @@ -44,7 +44,7 @@ let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) | Some _ | None -> ( match Map_ident.find_opt export_map x with - | Some (Lprim {primitive = Pmakeblock (_, _, Immutable); args}) -> + | Some (Lprim {primitive = Pmakeblock (_, Immutable); args}) -> Submodule (Ext_array.of_list_map args (fun lam -> Lam_arity_analysis.get_arity meta lam)) diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 1e9bb57bc1e..aba0e6ea212 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -201,7 +201,7 @@ let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = | NA -> lam () | SimpleForm l -> l | exception _ -> lam ()) - | Some (Constant (Const_block (_, Blk_record {fields}, ls))) -> ( + | Some (Constant (Const_block (Blk_record {fields}, ls))) -> ( match info with | Fld_record {name} -> ( let found = ref None in @@ -212,7 +212,7 @@ let field_flatten_get lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = | Some c when not (Lam_constant.is_allocating c) -> Lam.const c | _ -> lam ()) | _ -> lam ()) - | Some (Constant (Const_block (_, _, ls))) -> ( + | Some (Constant (Const_block (_, ls))) -> ( match Ext_list.nth_opt ls i with | None -> lam () | Some x when not (Lam_constant.is_allocating x) -> Lam.const x diff --git a/compiler/core/matching_polyfill.ml b/compiler/core/matching_polyfill.ml index f96bc712dd9..0188a0cc9ce 100644 --- a/compiler/core/matching_polyfill.ml +++ b/compiler/core/matching_polyfill.ml @@ -27,23 +27,6 @@ let () = Ctype.extract_concrete_typedecl let () = Ast_untagged_variants.expand_head := Ctype.expand_head -let names_from_construct_pattern (pat : Typedtree.pattern) = - let rec resolve_path n (path : Path.t) = - match Env.find_type path pat.pat_env with - | {type_kind = Type_variant cstrs; _} -> - Ast_untagged_variants.names_from_type_variant ~env:pat.pat_env cstrs - | {type_kind = Type_abstract; type_manifest = Some t; _} -> ( - match (Ctype.unalias t).desc with - | Tconstr (pathn, _, _) -> resolve_path (n + 1) pathn - | _ -> None) - | {type_kind = Type_abstract; type_manifest = None; _} -> None - | {type_kind = Type_record _ | Type_open (* Exceptions *); _} -> None - in - - match (Btype.repr pat.pat_type).desc with - | Tconstr (path, _, _) -> resolve_path 0 path - | _ -> assert false - (** Note it is a bit tricky when there is unbound var, its type will be Tvar which is too complicated to support subtyping diff --git a/compiler/core/matching_polyfill.mli b/compiler/core/matching_polyfill.mli index 5764981dcfc..81b1dd433dc 100644 --- a/compiler/core/matching_polyfill.mli +++ b/compiler/core/matching_polyfill.mli @@ -22,7 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val names_from_construct_pattern : - Typedtree.pattern -> Ast_untagged_variants.switch_names option - val variant_is_subtype : Env.t -> Types.row_desc -> Types.type_expr -> bool diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index fea0b53f1d7..3d2a4f5b4ab 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -64,7 +64,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = let init : lam = Lprim ( Pintcomp Ceq, - [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], + [arg; Lconst (Const_pointer (Pt_variant {name}))], Location.none ) in Ext_list.fold_left rest init (fun acc (hash, name) -> @@ -74,7 +74,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = acc; Lprim ( Pintcomp Ceq, - [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], + [arg; Lconst (Const_pointer (Pt_variant {name}))], Location.none ); ], Location.none )) @@ -93,8 +93,7 @@ let make_test_sequence_variant_constant (fail : lam option) (arg : lam) | [], None -> assert false let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) - (arg : lam) (int_lambda_list : (int * (string * lam)) list) - (_names : Ast_untagged_variants.switch_names option) = + (arg : lam) (int_lambda_list : (int * (string * lam)) list) = let int_lambda_list = convert int_lambda_list in match (int_lambda_list, fail) with | (_, act) :: rest, None | rest, Some act -> @@ -104,12 +103,11 @@ let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) | [], None -> assert false let call_switcher_variant_constr (loc : Location.t) (fail : lam option) - (arg : lam) int_lambda_list - (names : Ast_untagged_variants.switch_names option) : lam = + (arg : lam) int_lambda_list : lam = let v = Ident.create "variant" in Llet ( Alias, Pgenval, v, Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), - call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) + call_switcher_variant_constant loc fail (Lvar v) int_lambda_list ) diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index c5bab8ffa9d..23d02053bfe 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -22,21 +22,11 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type constructor_tag = { - cstr_name: Ast_untagged_variants.tag; - const: int; - non_const: int; -} - -type pointer_info = - | None - | Pt_constructor of constructor_tag - | Pt_assertfalse - | Some of string +type pointer_info = None | Pt_assertfalse | Some of string let string_of_pointer_info (x : pointer_info) : string option = match x with - | Some name | Pt_constructor {cstr_name = {name}; _} -> Some name + | Some name -> Some name | Pt_assertfalse -> Some "assert_false" | None -> None @@ -46,12 +36,15 @@ type t = | Const_js_true | Const_js_false | Const_int of {i: int32; comment: pointer_info} + | Const_constructor of Ast_untagged_variants.tag + (* Constant constructor of a nominal variant, emitted from its + canonical runtime descriptor rather than an ordinal *) | Const_char of int | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string | Const_pointer of string - | Const_block of int * Lambda.tag_info * t list + | Const_block of Lambda.tag_info * t list | Const_some of t | Const_module_alias (* eventually we can remove it, since we know @@ -69,6 +62,10 @@ let rec eq_approx (x : t) (y : t) = match y with | Const_int iy -> ix.i = iy.i | _ -> false) + | Const_constructor ix -> ( + match y with + | Const_constructor iy -> ix = iy + | _ -> false) | Const_char ix -> ( match y with | Const_char iy -> ix = iy @@ -89,9 +86,9 @@ let rec eq_approx (x : t) (y : t) = match y with | Const_pointer iy -> ix = iy | _ -> false) - | Const_block (ix, _, ixs) -> ( + | Const_block (ix, ixs) -> ( match y with - | Const_block (iy, _, iys) -> + | Const_block (iy, iys) -> ix = iy && Ext_list.for_all2_no_exn ixs iys eq_approx | _ -> false) | Const_some ix -> ( @@ -106,6 +103,6 @@ let rec is_allocating (c : t) : bool = | Const_some t -> is_allocating t | Const_block _ -> true | Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false - | Const_int _ | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ - | Const_pointer _ | Const_module_alias -> + | Const_int _ | Const_constructor _ | Const_char _ | Const_string _ + | Const_float _ | Const_bigint _ | Const_pointer _ | Const_module_alias -> false diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli index 846e29d7439..bcef7a00ae2 100644 --- a/compiler/frontend/lam_constant.mli +++ b/compiler/frontend/lam_constant.mli @@ -22,17 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type constructor_tag = { - cstr_name: Ast_untagged_variants.tag; - const: int; - non_const: int; -} - -type pointer_info = - | None - | Pt_constructor of constructor_tag - | Pt_assertfalse - | Some of string +type pointer_info = None | Pt_assertfalse | Some of string val string_of_pointer_info : pointer_info -> string option @@ -42,12 +32,15 @@ type t = | Const_js_true | Const_js_false | Const_int of {i: int32; comment: pointer_info} + | Const_constructor of Ast_untagged_variants.tag + (* Constant constructor of a nominal variant, emitted from its + canonical runtime descriptor rather than an ordinal *) | Const_char of int | Const_string of {s: string; delim: External_arg_spec.delim option} | Const_float of string | Const_bigint of bool * string | Const_pointer of string - | Const_block of int * Lambda.tag_info * t list + | Const_block of Lambda.tag_info * t list | Const_some of t (* eventually we can remove it, since we know [constant] is [undefined] or not diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index a95cd120d50..068c8053ad5 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -145,8 +145,75 @@ type tag_type = | Undefined (* literal or tagged block *) | Untagged of block_type (* untagged block *) type tag = {name: string; tag_type: tag_type option} -type block = {tag: tag; tag_name: string option; block_type: block_type option} -type switch_names = {consts: tag array; blocks: block array} + +type block_runtime = {tag: tag; tag_name: string option; untagged: bool} +(** Runtime information shared by construction and pattern matching for a + constructor carrying a payload. [block_type] is deliberately not part of + this value: it describes how a matcher recognizes an unboxed payload, not + how the value itself is constructed. *) + +type block = {runtime: block_runtime; block_type: block_type option} + +type constructor_case = Constant of tag | Block of block + +type variant_layout = { + constructors: constructor_case array; + constructors_by_name: (int * constructor_case) Map_string.t; +} +(** Canonical runtime layout in source-constructor order. *) + +type variant_dispatch = { + tag_name: string option; + block_types: block_type list; + literal_tags: tag_type list; + has_null: bool; + has_undefined: bool; + has_other_literal: bool; +} +(** The whole-variant information needed to choose a JavaScript dispatch + strategy. Constructor identity is carried by each switch arm instead. *) + +let dispatch_from_layout layout = + let tag_name = ref None in + let block_types = ref [] in + let literal_tags = ref [] in + let has_null = ref false in + let has_undefined = ref false in + let has_other_literal = ref false in + Array.iter + (function + | Constant {name; tag_type} -> ( + let tag = + match tag_type with + | Some tag -> tag + | None -> String name + in + literal_tags := tag :: !literal_tags; + match tag with + | Null -> has_null := true + | Undefined -> has_undefined := true + | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ -> + has_other_literal := true) + | Block {runtime = {tag_name = constructor_tag_name}; block_type} -> ( + if !tag_name = None then tag_name := constructor_tag_name; + match block_type with + | Some block_type -> block_types := block_type :: !block_types + | None -> ())) + layout.constructors; + { + tag_name = !tag_name; + block_types = !block_types; + literal_tags = !literal_tags; + has_null = !has_null; + has_undefined = !has_undefined; + has_other_literal = !has_other_literal; + } + +let constructor_by_name layout name = + snd (Map_string.find_exn layout.constructors_by_name name) + +let constructor_position layout name = + fst (Map_string.find_exn layout.constructors_by_name name) let tag_type_to_user_visible_string = function | String _ -> "string" @@ -340,6 +407,15 @@ let process_tag_name (attrs : Parsetree.attributes) = let get_tag_name (cstr : Types.constructor_declaration) = process_tag_name cstr.cd_attributes +let constructor_tag ~name attrs = {name; tag_type = process_tag_type attrs} + +let block_runtime ~name attrs = + { + tag = constructor_tag ~name attrs; + tag_name = process_tag_name attrs; + untagged = process_untagged attrs; + } + let is_nullary_variant (x : Types.constructor_arguments) = match x with | Types.Cstr_tuple [] -> true @@ -438,18 +514,14 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) | BigintType -> incr bigint_types | BooleanType -> incr boolean_types | StringType -> incr string_types); - invariant loc block.tag.name + invariant loc block.runtime.tag.name | None -> ()) else Ext_list.rev_iter blocks (fun (loc, block) -> - check_literal ~is_const:false ~loc block.tag) + check_literal ~is_const:false ~loc block.runtime.tag) let get_cstr_loc_tag (cstr : Types.constructor_declaration) = - ( cstr.cd_loc, - { - name = Ident.name cstr.cd_id; - tag_type = process_tag_type cstr.cd_attributes; - } ) + (cstr.cd_loc, constructor_tag ~name:(Ident.name cstr.cd_id) cstr.cd_attributes) let constructor_declaration_from_constructor_description ~env (cd : Types.constructor_description) : Types.constructor_declaration option @@ -463,24 +535,48 @@ let constructor_declaration_from_constructor_description ~env | _ -> None) | _ -> None -let names_from_type_variant ?(is_untagged_def = false) ~env +let layout_from_type_variant ?(is_untagged_def = false) ~env (cstrs : Types.constructor_declaration list) = let get_block (cstr : Types.constructor_declaration) : block = - let tag = snd (get_cstr_loc_tag cstr) in - {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr} + { + runtime = block_runtime ~name:(Ident.name cstr.cd_id) cstr.cd_attributes; + block_type = get_block_type ~env cstr; + } in - let consts, blocks = - Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr -> + let located_constructors = + List.map + (fun (cstr : Types.constructor_declaration) -> if is_nullary_variant cstr.cd_args then - (get_cstr_loc_tag cstr :: consts, blocks) - else (consts, (cstr.cd_loc, get_block cstr) :: blocks)) + let loc, tag = get_cstr_loc_tag cstr in + (loc, Constant tag) + else (cstr.cd_loc, Block (get_block cstr))) + cstrs + in + let consts, blocks = + Ext_list.fold_left located_constructors ([], []) + (fun (consts, blocks) (loc, constructor) -> + match constructor with + | Constant tag -> ((loc, tag) :: consts, blocks) + | Block block -> (consts, (loc, block) :: blocks)) in check_invariant ~is_untagged_def ~consts ~blocks; - let blocks = blocks |> List.map snd in - let consts = consts |> List.map snd in - let consts = Ext_array.reverse_of_list consts in - let blocks = Ext_array.reverse_of_list blocks in - Some {consts; blocks} + let constructors = + Array.of_list + (List.map (fun (_, constructor) -> constructor) located_constructors) + in + let constructors_by_name = + let _, constructors_by_name = + List.fold_left2 + (fun (index, constructors_by_name) + (cstr : Types.constructor_declaration) (_, constructor) -> + ( index + 1, + Map_string.add constructors_by_name (Ident.name cstr.cd_id) + (index, constructor) )) + (0, Map_string.empty) cstrs located_constructors + in + constructors_by_name + in + Some {constructors; constructors_by_name} let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter @@ -520,7 +616,7 @@ type well_formedness_check = { let check_well_formed ~env {is_untagged_def; cstrs} = check_tag_field_conflicts cstrs; - ignore (names_from_type_variant ~env ~is_untagged_def cstrs) + ignore (layout_from_type_variant ~env ~is_untagged_def cstrs) let has_undefined_literal attrs = process_tag_type attrs = Some Undefined diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml index b9bc75c61fb..1255d2974f3 100644 --- a/compiler/ml/clflags.ml +++ b/compiler/ml/clflags.ml @@ -61,8 +61,6 @@ let color = ref None (* -color *) -let unboxed_types = ref false - type mli_status = Mli_exists | Mli_non_exists let assume_no_mli = ref Mli_non_exists let dont_record_crc_unit : string option ref = ref None diff --git a/compiler/ml/clflags.mli b/compiler/ml/clflags.mli index c597b2a2d6a..e532fd6f7d5 100644 --- a/compiler/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -29,8 +29,6 @@ val editor_mode : bool ref val parse_color_setting : string -> Misc.Color.setting option val color : Misc.Color.setting option ref -val unboxed_types : bool ref - val reset_dump_state : unit -> unit type mli_status = Mli_exists | Mli_non_exists diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 84187a94f78..7f3913e84a5 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -908,7 +908,7 @@ let new_declaration newtype manifest = type_loc = Location.none; type_attributes = []; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } @@ -4192,7 +4192,7 @@ let nondep_type_decl env mid id is_covariant decl = type_loc = decl.type_loc; type_attributes = decl.type_attributes; type_immediate = decl.type_immediate; - type_unboxed = decl.type_unboxed; + type_representation = decl.type_representation; type_inlined_types = decl.type_inlined_types; } with Not_found -> diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index a33e2c57f19..54184b453d0 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -68,10 +68,10 @@ let constructor_args priv cd_args cd_res path rep = | Cstr_record lbls -> let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in let type_params = Type_set.elements arg_vars_set in - let type_unboxed = + let type_representation = match rep with - | Record_unboxed _ -> unboxed_true_default_false - | _ -> unboxed_false_default_false + | Record_unboxed _ -> Transparent + | _ -> Boxed in let tdecl = { @@ -85,7 +85,7 @@ let constructor_args priv cd_args cd_res path rep = type_loc = Location.none; type_attributes = []; type_immediate = false; - type_unboxed; + type_representation; type_inlined_types = []; } in @@ -107,7 +107,7 @@ let constructor_descrs ty_path decl cstrs = (fun {cd_args; _} -> if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) cstrs; - let rec describe_constructors idx_const idx_nonconst = function + let rec describe_constructors = function | [] -> [] | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> let ty_res = @@ -115,26 +115,14 @@ let constructor_descrs ty_path decl cstrs = | Some ty_res' -> ty_res' | None -> ty_res in - let tag, descr_rem = - match cd_args with - | _ when decl.type_unboxed.unboxed -> - assert (rem = []); - (Cstr_unboxed, []) - | Cstr_tuple [] -> - ( Cstr_constant idx_const, - describe_constructors (idx_const + 1) idx_nonconst rem ) - | _ -> - ( Cstr_block idx_nonconst, - describe_constructors idx_const (idx_nonconst + 1) rem ) - in + let descr_rem = describe_constructors rem in let cstr_name = Ident.name cd_id in let existentials, cstr_args, cstr_inlined = let representation = - if decl.type_unboxed.unboxed then Record_unboxed true + if decl.type_representation = Transparent then Record_unboxed true else Record_inlined { - tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; attrs = cd_attributes; @@ -151,9 +139,13 @@ let constructor_descrs ty_path decl cstrs = cstr_existentials = existentials; cstr_args; cstr_arity = List.length cstr_args; - cstr_tag = tag; - cstr_consts = !num_consts; - cstr_nonconsts = !num_nonconsts; + cstr_identity = + Ordinary_constructor {type_path = ty_path; name = cstr_name}; + cstr_transparent = + !num_consts = 0 && !num_nonconsts = 1 && cstr_args <> [] + && List.exists + (fun (attribute, _) -> attribute.txt = "unboxed") + cd_attributes; cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; @@ -163,7 +155,7 @@ let constructor_descrs ty_path decl cstrs = in (cd_id, cstr) :: descr_rem in - let result = describe_constructors 0 0 cstrs in + let result = describe_constructors cstrs in match result with | [ (({Ident.name = "None"} as a_id), ({cstr_args = []} as a_descr)); @@ -203,9 +195,8 @@ let extension_descr path_ext ext = cstr_existentials = existentials; cstr_args; cstr_arity = List.length cstr_args; - cstr_tag = Cstr_extension path_ext; - cstr_consts = -1; - cstr_nonconsts = -1; + cstr_identity = Extension_constructor path_ext; + cstr_transparent = false; cstr_private = ext.ext_private; cstr_generalized = ext.ext_ret_type <> None; cstr_loc = ext.ext_loc; diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index ce0403c9317..b28b4828ae9 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -510,7 +510,7 @@ let is_ident = function | Pdot _ | Papply _ -> false let is_local_ext = function - | {cstr_tag = Cstr_extension p} -> is_ident p + | {cstr_identity = Extension_constructor p} -> is_ident p | _ -> false let diff env1 env2 = @@ -851,7 +851,7 @@ let find_type_full path env = Ext_list.filter (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false) (function - | {cstr_tag = Cstr_extension _} -> true + | {cstr_identity = Extension_constructor _} -> true | _ -> false) in @@ -1092,8 +1092,8 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env = let has_local_constraints env = not (Path_map.is_empty env.local_constraints) let cstr_shadow cstr1 cstr2 = - match (cstr1.cstr_tag, cstr2.cstr_tag) with - | Cstr_extension _, Cstr_extension _ -> true + match (cstr1.cstr_identity, cstr2.cstr_identity) with + | Extension_constructor _, Extension_constructor _ -> true | _ -> false let lbl_shadow _lbl1 _lbl2 = false @@ -1211,8 +1211,8 @@ let lookup_all_constructors ?loc lid env = let mark_constructor usage env name desc = if not (is_implicit_coercion env) then - match desc.cstr_tag with - | Cstr_extension _ -> ( + match desc.cstr_identity with + | Extension_constructor _ -> ( let ty_path = ty_path desc.cstr_res in let ty_name = Path.last ty_path in try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 05753d36c86..62798636473 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -350,8 +350,8 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = in match ( decl2.type_kind, - decl1.type_unboxed.unboxed || untagged1, - decl2.type_unboxed.unboxed || untagged2 ) + decl1.type_representation = Transparent || untagged1, + decl2.type_representation = Transparent || untagged2 ) with | Type_abstract, _, _ -> [] | _, true, false -> [Unboxed_representation false] diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 987d844ddd6..9f1abcb9bb5 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -19,16 +19,14 @@ type tag_info = | Blk_constructor of { name: string; num_nonconst: int; - tag: int; - attrs: Parsetree.attributes; + runtime: Ast_untagged_variants.block_runtime; } | Blk_record_inlined of { name: string; num_nonconst: int; - tag: int; fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; - attrs: Parsetree.attributes; + runtime: Ast_untagged_variants.block_runtime; } | Blk_tuple | Blk_poly_var of string @@ -47,14 +45,15 @@ type tag_info = mutable_flag: Asttypes.mutable_flag; } -let tag_of_tag_info (tag : tag_info) = +(* Label used by the lambda printer for a block; blocks carry no + numeric tag anymore *) +let tag_label_of_tag_info (tag : tag_info) = match tag with - | Blk_constructor {tag} | Blk_record_inlined {tag} -> tag + | Blk_constructor {name} | Blk_record_inlined {name} -> name | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_some (* tag not make sense *) - | Blk_some_not_nested (* tag not make sense *) - | Blk_record_ext _ (* similar to Blk_extension*) -> - 0 + | Blk_module_export _ | Blk_extension | Blk_some | Blk_some_not_nested + | Blk_record_ext _ -> + "0" let mutable_flag_of_tag_info (tag : tag_info) = match tag with @@ -98,7 +97,7 @@ let blk_record_ext fields mutable_flag = in Blk_record_ext {fields = all_labels_info; mutable_flag} -let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag = +let blk_record_inlined fields name num_nonconst ~runtime mutable_flag = let fields = Array.map (fun ((lbl : label), _, _) -> @@ -106,7 +105,7 @@ let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag = lbl.lbl_optional )) fields in - Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; attrs} + Blk_record_inlined {fields; name; num_nonconst; mutable_flag; runtime} let ref_tag_info : tag_info = Blk_record {fields = [|("contents", false)|]; mutable_flag = Mutable} @@ -311,12 +310,7 @@ and value_kind = Pgenval and raise_kind = Raise_regular | Raise_reraise type pointer_info = - | Pt_constructor of { - name: string; - const: int; - non_const: int; - attrs: Parsetree.attributes; - } + | Pt_constructor of Ast_untagged_variants.tag | Pt_variant of {name: string} | Pt_module_alias | Pt_shape_none @@ -324,7 +318,7 @@ type pointer_info = type structured_constant = | Const_base of Asttypes.constant - | Const_pointer of int * pointer_info + | Const_pointer of pointer_info | Const_block of tag_info * structured_constant list | Const_immstring of string | Const_false @@ -385,26 +379,36 @@ and lambda_apply = { ap_transformed_jsx: bool; } -and lambda_switch = { - sw_numconsts: int; - sw_consts: (int * lambda) list; - sw_numblocks: int; - sw_blocks: (int * lambda) list; - sw_failaction: lambda option; - sw_names: Ast_untagged_variants.switch_names option; +and switch_key = + | Switch_int of int + | Switch_constructor of Ast_untagged_variants.constructor_case + +and switch_dispatch = + | Switch_direct + | Switch_variant of Ast_untagged_variants.variant_dispatch + +and 'a switch = { + sw_consts_full: bool; + sw_consts: (switch_key * 'a) list; + sw_blocks_full: bool; + sw_blocks: (switch_key * 'a) list; + sw_failaction: 'a option; + sw_dispatch: switch_dispatch; } +and lambda_switch = lambda switch + (* This is actually a dummy value not necessary "()", it can be used as a place holder for module alias etc. *) let const_unit = Const_pointer - (0, Pt_constructor {name = "()"; const = 1; non_const = 0; attrs = []}) + (Pt_constructor {Ast_untagged_variants.name = "()"; tag_type = None}) -let lambda_assert_false = Lconst (Const_pointer (0, Pt_assertfalse)) +let lambda_assert_false = Lconst (Const_pointer Pt_assertfalse) -let lambda_module_alias = Lconst (Const_pointer (0, Pt_module_alias)) +let lambda_module_alias = Lconst (Const_pointer Pt_module_alias) let lambda_unit = Lconst const_unit diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index efe4d9802b5..329bdc38b92 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -23,16 +23,14 @@ type tag_info = | Blk_constructor of { name: string; num_nonconst: int; - tag: int; - attrs: Parsetree.attributes; + runtime: Ast_untagged_variants.block_runtime; } | Blk_record_inlined of { name: string; num_nonconst: int; - tag: int; fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; - attrs: Parsetree.attributes; + runtime: Ast_untagged_variants.block_runtime; } | Blk_tuple | Blk_poly_var of string @@ -59,7 +57,7 @@ type tag_info = val find_name : Parsetree.attribute -> Asttypes.label option -val tag_of_tag_info : tag_info -> int +val tag_label_of_tag_info : tag_info -> string val mutable_flag_of_tag_info : tag_info -> mutable_flag val blk_record : (Types.label_description * Typedtree.record_label_definition * bool) array -> @@ -75,8 +73,7 @@ val blk_record_inlined : (Types.label_description * Typedtree.record_label_definition * bool) array -> string -> int -> - tag:int -> - attrs:Parsetree.attributes -> + runtime:Ast_untagged_variants.block_runtime -> mutable_flag -> tag_info @@ -118,12 +115,7 @@ val fld_record_extension_set : Types.label_description -> set_field_dbg_info type immediate_or_pointer = Immediate | Pointer type pointer_info = - | Pt_constructor of { - name: string; - const: int; - non_const: int; - attrs: Parsetree.attributes; - } + | Pt_constructor of Ast_untagged_variants.tag | Pt_variant of {name: string} | Pt_module_alias | Pt_shape_none @@ -284,7 +276,7 @@ and raise_kind = Raise_regular | Raise_reraise type structured_constant = | Const_base of constant - | Const_pointer of int * pointer_info + | Const_pointer of pointer_info | Const_block of tag_info * structured_constant list | Const_immstring of string | Const_false @@ -359,15 +351,25 @@ and lambda_apply = { ap_transformed_jsx: bool; } -and lambda_switch = { - sw_numconsts: int; (* Number of integer cases *) - sw_consts: (int * lambda) list; (* Integer cases *) - sw_numblocks: int; (* Number of tag block cases *) - sw_blocks: (int * lambda) list; (* Tag block cases *) - sw_failaction: lambda option; (* Action to take if failure *) - sw_names: Ast_untagged_variants.switch_names option; +and switch_key = + | Switch_int of int + | Switch_constructor of Ast_untagged_variants.constructor_case + +and switch_dispatch = + | Switch_direct + | Switch_variant of Ast_untagged_variants.variant_dispatch + +and 'a switch = { + sw_consts_full: bool; + sw_consts: (switch_key * 'a) list; + sw_blocks_full: bool; + sw_blocks: (switch_key * 'a) list; + sw_failaction: 'a option; (* Action to take if failure *) + sw_dispatch: switch_dispatch; } +and lambda_switch = lambda switch + (* Lambda code for the middle-end. * In the closure case the code is a sequence of assignments to a preallocated block of size [main_module_block_size] using diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index f49dfc7d27f..635e63fa1da 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -927,7 +927,7 @@ and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_, {cstr_tag = Cstr_extension _}, _) -> + | Tpat_construct (_, {cstr_identity = Extension_constructor _}, _) -> split_naive cls args def k | _ -> ( let group = get_group ex_pat in @@ -1203,7 +1203,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = make_args first_pos let get_key_constr = function - | {pat_desc = Tpat_construct (_, cstr, _)} -> cstr.cstr_tag + | {pat_desc = Tpat_construct (_, cstr, _)} -> cstr | _ -> assert false let get_args_constr p rem = @@ -1271,8 +1271,10 @@ let make_constr_matching p def ctx = function if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then (arg, Alias) :: argl else - match cstr.cstr_tag with - | Cstr_block _ when Datarepr.constructor_has_optional_shape cstr -> + match cstr.cstr_identity with + | Ordinary_constructor _ + when cstr.cstr_args <> [] + && Datarepr.constructor_has_optional_shape cstr -> let from_option = match p.pat_desc with | Tpat_construct (_, _, [{pat_type; pat_env}]) @@ -1281,11 +1283,10 @@ let make_constr_matching p def ctx = function | _ -> Pval_from_option in (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl - | Cstr_constant _ | Cstr_block _ -> + | Ordinary_constructor _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) - | Cstr_unboxed -> (arg, Alias) :: argl - | Cstr_extension _ -> + | Extension_constructor _ -> make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl ~fld_info:Fld_extension in @@ -1301,8 +1302,8 @@ let make_constr_matching p def ctx = function } let divide_constructor ctx pm = - divide make_constr_matching Types.equal_tag get_key_constr get_args_constr ctx - pm + divide make_constr_matching Types.same_constructor get_key_constr + get_args_constr ctx pm (* Matching against a variant *) @@ -1358,19 +1359,17 @@ let divide_variant row ctx {cases = cl; args = al; default = def} = with Not_found -> true then variants else - let tag = Btype.hash_variant lab in - let ( = ) ((a : string), (b : Types.constructor_tag)) (c, d) = - a = c && Types.equal_tag b d - in + (* key: label of the variant case, and whether it is constant *) + let ( = ) ((a : string), (b : bool)) (c, d) = a = c && b = d in match pato with | None -> add (make_variant_matching_constant p lab def ctx) - variants ( = ) (lab, Cstr_constant tag) (patl, action) al + variants ( = ) (lab, true) (patl, action) al | Some pat -> add (make_variant_matching_nonconst p lab def ctx) - variants ( = ) (lab, Cstr_block tag) + variants ( = ) (lab, false) (pat :: patl, action) al) | _ -> [] @@ -1663,20 +1662,20 @@ module S_arg = struct let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts ~offset sw_names = + let make_switch loc arg cases acts ~offset = let l = ref [] in for i = Array.length cases - 1 downto 0 do - l := (offset + i, acts.(cases.(i))) :: !l + l := (Switch_int (offset + i), acts.(cases.(i))) :: !l done; Lswitch ( arg, { - sw_numconsts = Array.length cases; + sw_consts_full = true; sw_consts = !l; - sw_numblocks = 0; + sw_blocks_full = true; sw_blocks = []; sw_failaction = None; - sw_names; + sw_dispatch = Switch_direct; }, loc ) let make_catch = make_catch_delayed @@ -1749,10 +1748,16 @@ let reintroduce_fail sw = | Some j -> j <> default | None -> true) in + let sw_consts = remove sw.sw_consts in + let sw_blocks = remove sw.sw_blocks in { sw with - sw_consts = remove sw.sw_consts; - sw_blocks = remove sw.sw_blocks; + sw_consts_full = + sw.sw_consts_full && List.length sw_consts = List.length sw.sw_consts; + sw_consts; + sw_blocks_full = + sw.sw_blocks_full && List.length sw_blocks = List.length sw.sw_blocks; + sw_blocks; sw_failaction = Some (make_exit default); } else sw @@ -1864,9 +1869,9 @@ let as_interval fail low high l = | None -> as_interval_nofail l | Some act -> as_interval_canfail act low high l ) -let call_switcher loc fail arg low high int_lambda_list sw_names = +let call_switcher loc fail arg low high int_lambda_list = let edges, (cases, actions) = as_interval fail low high int_lambda_list in - Switcher.zyva loc edges arg cases actions sw_names + Switcher.zyva loc edges arg cases actions let rec list_as_pat = function | [] -> fatal_error "Matching.list_as_pat" @@ -1945,7 +1950,7 @@ let mk_failaction_pos partial seen ctx defs = | Some lam -> string_of_lam lam); (fail, [], jumps)) -let combine_constant names loc arg cst partial ctx def +let combine_constant loc arg cst partial ctx def (const_lambda_list, total, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = @@ -1958,7 +1963,7 @@ let combine_constant names loc arg cst partial ctx def | _ -> assert false) const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list names + call_switcher loc fail arg min_int max_int int_lambda_list | Const_char _ -> let int_lambda_list = List.map @@ -1967,7 +1972,7 @@ let combine_constant names loc arg cst partial ctx def | _ -> assert false) const_lambda_list in - call_switcher loc fail arg 0 max_int int_lambda_list names + call_switcher loc fail arg 0 max_int int_lambda_list | Const_string _ -> (* Note as the bytecode compiler may resort to dichotomic search, the clauses of stringswitch are sorted with duplicates removed. @@ -2000,26 +2005,23 @@ let split_cases tag_lambda_list = | [] -> ([], []) | (cstr, act) :: rem -> ( let consts, nonconsts = split_rec rem in - match cstr with - | Cstr_constant n -> ((n, act) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, act) :: nonconsts) - | Cstr_unboxed -> (consts, (0, act) :: nonconsts) - | Cstr_extension _ -> assert false) + match cstr.cstr_identity with + | Ordinary_constructor _ -> + if cstr.cstr_args = [] then ((cstr, act) :: consts, nonconsts) + else (consts, (cstr, act) :: nonconsts) + | Extension_constructor _ -> assert false) in - let const, nonconst = split_rec tag_lambda_list in - (sort_int_lambda_list const, sort_int_lambda_list nonconst) + split_rec tag_lambda_list (* refine [split_cases] and [split_variant_cases] *) let split_variant_cases tag_lambda_list = let rec split_rec = function | [] -> ([], []) - | ((name, cstr), act) :: rem -> ( + | ((name, is_const), act) :: rem -> let consts, nonconsts = split_rec rem in - match cstr with - | Cstr_constant n -> ((n, (name, act)) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, (name, act)) :: nonconsts) - | Cstr_unboxed -> assert false - | Cstr_extension _ -> assert false) + let n = Btype.hash_variant name in + if is_const then ((n, (name, act)) :: consts, nonconsts) + else (consts, (n, (name, act)) :: nonconsts) in let const, nonconst = split_rec tag_lambda_list in (sort_int_lambda_list const, sort_int_lambda_list nonconst) @@ -2029,15 +2031,33 @@ let get_extension_cases tag_lambda_list = | [] -> [] | (cstr, act) :: rem -> ( let nonconsts = split_rec rem in - match cstr with - | Cstr_extension path -> (path, act) :: nonconsts - | _ -> assert false) + match cstr.cstr_identity with + | Extension_constructor path -> (path, act) :: nonconsts + | Ordinary_constructor _ -> assert false) in split_rec tag_lambda_list -let combine_constructor sw_names loc arg ex_pat cstr partial ctx def +let sort_constructor_cases layout cases = + List.sort + (fun (cstr1, _) (cstr2, _) -> + let index cstr = + Ast_untagged_variants.constructor_position layout cstr.cstr_name + in + Int.compare (index cstr1) (index cstr2)) + cases + +let constructor_switch_key layout (cstr : Types.constructor_description) = + Switch_constructor + (Ast_untagged_variants.constructor_by_name layout cstr.cstr_name) + +let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = - if cstr.cstr_consts < 0 then + let is_extension = + match cstr.cstr_identity with + | Extension_constructor _ -> true + | Ordinary_constructor _ -> false + in + if is_extension then (* Special cases for extensions *) let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = @@ -2067,8 +2087,22 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (lambda1, jumps_union local_jumps total1) else (* Regular concrete type *) + let layout = + match sw_layout with + | Some layout -> layout + | None -> assert false + in + let num_consts, num_nonconsts = + Array.fold_left + (fun (consts, nonconsts) (case : Ast_untagged_variants.constructor_case) + -> + match case with + | Constant _ -> (consts + 1, nonconsts) + | Block _ -> (consts, nonconsts + 1)) + (0, 0) layout.Ast_untagged_variants.constructors + in let ncases = List.length tag_lambda_list - and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + and nconstrs = num_consts + num_nonconsts in let sig_complete = ncases = nconstrs in let fail_opt, fails, local_jumps = if sig_complete then (None, [], jumps_empty) @@ -2077,12 +2111,14 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def let tag_lambda_list = fails @ tag_lambda_list in let consts, nonconsts = split_cases tag_lambda_list in + let consts = sort_constructor_cases layout consts + and nonconsts = sort_constructor_cases layout nonconsts in let lambda1 = match (fail_opt, same_actions tag_lambda_list) with | None, Some act -> act (* Identical actions, no failure *) | _ -> ( - match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with - | 1, 1, [(0, act1)], [(0, act2)] + match (num_consts, num_nonconsts, consts, nonconsts) with + | 1, 1, [(_, act1)], [(_, act2)] when cstr.cstr_name = "::" || cstr.cstr_name = "[]" || Datarepr.constructor_has_optional_shape cstr -> (* Typically, match on lists, will avoid isint primitive in that @@ -2094,45 +2130,49 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) in Lifthenelse (arg, act2, act1) - | 2, 0, [(i1, act1); (_, act2)], [] - when cstr.cstr_name = "true" || cstr.cstr_name = "false" -> - if i1 = 0 then Lifthenelse (arg, act2, act1) - else Lifthenelse (arg, act1, act2) - | n, 0, _, [] when false (* relies on tag being an int *) -> - (* The type defines constant constructors only *) - call_switcher loc fail_opt arg 0 (n - 1) consts sw_names - | n, _, _, _ -> ( - let act0 = - (* = Some act when all non-const constructors match to act *) - match (fail_opt, nonconsts) with - | Some a, [] -> Some a - | Some _, _ -> - if List.length nonconsts = cstr.cstr_nonconsts then - same_actions nonconsts - else None - | None, _ -> same_actions nonconsts + | 2, 0, _, [] when cstr.cstr_name = "true" || cstr.cstr_name = "false" + -> + let find_action name = + match + Ext_list.find_opt consts (fun (cstr, action) -> + if cstr.cstr_name = name then Some action else None) + with + | Some action -> action + | None -> assert false in - match act0 with - | Some act when false (* relies on tag being an int *) -> - Lifthenelse - ( Lprim (Pisint, [arg], loc), - call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, - act ) - (* Emit a switch, as bytecode implements this sophisticated instruction *) - | _ -> - let sw = - { - sw_numconsts = cstr.cstr_consts; - sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; - sw_blocks = nonconsts; - sw_failaction = fail_opt; - sw_names; - } - in - let hs, sw = share_actions_sw sw in - let sw = reintroduce_fail sw in - hs (Lswitch (arg, sw, loc)))) + let false_action = find_action "false" + and true_action = find_action "true" in + Lifthenelse (arg, true_action, false_action) + | _, _, _, _ -> + (* Emit a switch after constructor identity has been resolved to its + canonical runtime representation. *) + let consts = + List.map + (fun (cstr, action) -> + (constructor_switch_key layout cstr, action)) + consts + in + let nonconsts = + List.map + (fun (cstr, action) -> + (constructor_switch_key layout cstr, action)) + nonconsts + in + let sw = + { + sw_consts_full = List.length consts >= num_consts; + sw_consts = consts; + sw_blocks_full = List.length nonconsts >= num_nonconsts; + sw_blocks = nonconsts; + sw_failaction = fail_opt; + sw_dispatch = + Switch_variant + (Ast_untagged_variants.dispatch_from_layout layout); + } + in + let hs, sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg, sw, loc))) in (lambda1, jumps_union local_jumps total1) @@ -2143,12 +2183,11 @@ let make_test_sequence_variant_constant fail arg int_lambda_list = in Switcher.test_sequence arg cases actions -let call_switcher_variant_constant loc fail arg int_lambda_list names = +let call_switcher_variant_constant loc fail arg int_lambda_list = call_switcher loc fail arg min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) - names -let call_switcher_variant_constr loc fail arg int_lambda_list names = +let call_switcher_variant_constr loc fail arg int_lambda_list = let v = Ident.create "variant" in Llet ( Alias, @@ -2156,15 +2195,13 @@ let call_switcher_variant_constr loc fail arg int_lambda_list names = v, Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher loc fail (Lvar v) min_int max_int - (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) - names ) + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) ) let call_switcher_variant_constant : (Location.t -> Lambda.lambda option -> Lambda.lambda -> (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> Lambda.lambda) ref = ref call_switcher_variant_constant @@ -2174,7 +2211,6 @@ let call_switcher_variant_constr : Lambda.lambda option -> Lambda.lambda -> (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> Lambda.lambda) ref = ref call_switcher_variant_constr @@ -2187,8 +2223,8 @@ let make_test_sequence_variant_constant : ref = ref make_test_sequence_variant_constant -let combine_variant names loc row arg partial ctx def - (tag_lambda_list, total1, _pats) = +let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats) + = let row = Btype.row_repr row in let num_constr = ref 0 in if row.row_closed then @@ -2227,28 +2263,26 @@ let combine_variant names loc row arg partial ctx def (* One can compare integers and pointers *) !make_test_sequence_variant_constant fail arg consts | [], _ -> ( - let lam = !call_switcher_variant_constr loc fail arg nonconsts names in + let lam = !call_switcher_variant_constr loc fail arg nonconsts in (* One must not dereference integers *) match fail with | None -> lam | Some fail -> test_int_or_block arg fail lam) | _, _ -> - let lam_const = - !call_switcher_variant_constant loc fail arg consts names + let lam_const = !call_switcher_variant_constant loc fail arg consts and lam_nonconst = - !call_switcher_variant_constr loc fail arg nonconsts names + !call_switcher_variant_constr loc fail arg nonconsts in test_int_or_block arg lam_const lam_nonconst) in (lambda1, jumps_union local_jumps total1) -let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) - = +let combine_array loc arg partial ctx def (len_lambda_list, total1, _pats) = let fail, local_jumps = mk_failaction_neg partial ctx def in let lambda1 = let newvar = Ident.create "len" in let switch = - call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names + call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list in bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch in @@ -2423,10 +2457,23 @@ let arg_to_var arg cls = let v = name_pattern "match" cls in (v, Lvar v) -(* To be set by Lam_compile *) -let names_from_construct_pattern : - (pattern -> Ast_untagged_variants.switch_names option) ref = - ref (fun _ -> None) +(* Resolve the canonical variant layout of a constructor pattern's type, + following manifest chains to the declaration *) +let layout_from_construct_pattern (pat : pattern) = + let rec resolve_path (path : Path.t) = + match Env.find_type path pat.pat_env with + | {type_kind = Type_variant cstrs} -> + Ast_untagged_variants.layout_from_type_variant ~env:pat.pat_env cstrs + | {type_kind = Type_abstract; type_manifest = Some t} -> ( + match (Ctype.unalias t).desc with + | Tconstr (pathn, _, _) -> resolve_path pathn + | _ -> None) + | {type_kind = Type_abstract; type_manifest = None} -> None + | {type_kind = Type_record _ | Type_open (* Exceptions *)} -> None + in + match (Btype.repr pat.pat_type).desc with + | Tconstr (path, _, _) -> resolve_path path + | _ -> assert false (* The main compilation function. @@ -2492,32 +2539,29 @@ and do_compile_matching repr partial ctx arg pmh = (divide_record lbl.lbl_all (normalize_pat pat)) ctx_combine repr partial ctx pm | Tpat_constant cst -> - let names = None in compile_test (compile_match repr partial) partial divide_constant - (combine_constant names pat.pat_loc arg cst partial) + (combine_constant pat.pat_loc arg cst partial) ctx pm | Tpat_construct (_, cstr, _) -> - let sw_names = !names_from_construct_pattern pat in + let sw_layout = layout_from_construct_pattern pat in compile_test (compile_match repr partial) partial divide_constructor - (combine_constructor sw_names pat.pat_loc arg pat cstr partial) + (combine_constructor sw_layout pat.pat_loc arg pat cstr partial) ctx pm | Tpat_array _ -> - let names = None in compile_test (compile_match repr partial) partial divide_array - (combine_array names pat.pat_loc arg partial) + (combine_array pat.pat_loc arg partial) ctx pm | Tpat_variant (_, _, row) -> - let names = None in compile_test (compile_match repr partial) partial (divide_variant !row) - (combine_variant names pat.pat_loc !row arg partial) + (combine_variant pat.pat_loc !row arg partial) ctx pm | _ -> assert false) | PmVar {inside = pmh; var_arg = arg} -> diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli index 8ad736202fe..041eac3b9d1 100644 --- a/compiler/ml/matching.mli +++ b/compiler/ml/matching.mli @@ -23,7 +23,6 @@ val call_switcher_variant_constant : Lambda.lambda option -> Lambda.lambda -> (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> Lambda.lambda) ref @@ -32,7 +31,6 @@ val call_switcher_variant_constr : Lambda.lambda option -> Lambda.lambda -> (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> Lambda.lambda) ref @@ -59,7 +57,3 @@ val for_multiple_match : exception Cannot_flatten val flatten_pattern : int -> pattern -> pattern list - -(* Expand stringswitch to string test tree *) -val names_from_construct_pattern : - (pattern -> Ast_untagged_variants.switch_names option) ref diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 039061936de..3b9d8c88685 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -141,8 +141,18 @@ let all_coherent column = | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _ | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) -> assert false - | Tpat_construct (_, c, _), Tpat_construct (_, c', _) -> - c.cstr_consts = c'.cstr_consts && c.cstr_nonconsts = c'.cstr_nonconsts + | Tpat_construct _, Tpat_construct _ -> ( + (* Simplification of or- and GADT-refined patterns can produce columns + mixing constructors of different types; such columns are incoherent + and excluded from the analysis. Compare the declared types. *) + let head_path p = + match (Ctype.expand_head p.pat_env p.pat_type).desc with + | Tconstr (path, _, _) -> Some path + | _ -> None + in + match (head_path hp1, head_path hp2) with + | Some path1, Some path2 -> Path.same path1 path2 + | _ -> false) | Tpat_constant c1, Tpat_constant c2 -> ( match (c1, c2) with | Const_char _, Const_char _ @@ -321,11 +331,9 @@ module Compat = struct | _, _ -> false end -let equal_tag c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag - -let compat = Compat.compat ~equal_cd:equal_tag +let compat = Compat.compat ~equal_cd:Types.same_constructor -and compats = Compat.compats ~equal_cd:equal_tag +and compats = Compat.compats ~equal_cd:Types.same_constructor (* Due to (potential) rebinding, two extension constructors of the same arity type may equal *) @@ -479,11 +487,24 @@ let pretty_matrix (pss : matrix) = (* Utilities for matching *) (****************************) +let rec get_variant_constructors env ty = + match (Ctype.repr ty).desc with + | Tconstr (path, _, _) -> ( + try + match Env.find_type path env with + | {type_kind = Type_variant _} -> fst (Env.find_type_descrs path env) + | {type_manifest = Some _} -> + get_variant_constructors env + (Ctype.expand_head_once env (clean_copy ty)) + | _ -> fatal_error "Parmatch.get_variant_constructors" + with Not_found -> fatal_error "Parmatch.get_variant_constructors") + | _ -> fatal_error "Parmatch.get_variant_constructors" + (* Check top matching *) let simple_match p1 p2 = match (p1.pat_desc, p2.pat_desc) with | Tpat_construct (_, c1, _), Tpat_construct (_, c2, _) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag + Types.same_constructor c1 c2 | Tpat_variant (l1, _, _), Tpat_variant (l2, _, _) -> l1 = l2 | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 | Tpat_record _, Tpat_record _ -> true @@ -845,9 +866,12 @@ let row_of_pat pat = let full_match closing env = match env with - | ({pat_desc = Tpat_construct (_, c, _)}, _) :: _ -> - if c.cstr_consts < 0 then false (* extensions *) - else List.length env = c.cstr_consts + c.cstr_nonconsts + | (({pat_desc = Tpat_construct (_, c, _)} as p), _) :: _ -> ( + match c.cstr_identity with + | Extension_constructor _ -> false + | Ordinary_constructor _ -> + List.length env + = List.length (get_variant_constructors p.pat_env c.cstr_res)) | (({pat_desc = Tpat_variant _} as p), _) :: _ -> let fields = List.map @@ -891,42 +915,16 @@ let should_extend ext env = | [] -> assert false | (p, _) :: _ -> ( match p.pat_desc with - | Tpat_construct - (_, {cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed}, _) -> + | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, _) -> let path = get_type_path p.pat_type p.pat_env in Path.same path ext - | Tpat_construct (_, {cstr_tag = Cstr_extension _}, _) -> false + | Tpat_construct (_, {cstr_identity = Extension_constructor _}, _) -> + false | Tpat_constant _ | Tpat_tuple _ | Tpat_variant _ | Tpat_record _ | Tpat_array _ -> false | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false)) -module Constructor_tag_hashtbl = Hashtbl.Make (struct - type t = Types.constructor_tag - let hash = Hashtbl.hash - let equal = Types.equal_tag -end) - -(* complement constructor tags *) -let complete_tags nconsts nconstrs tags = - let seen_const = Array.make nconsts false - and seen_constr = Array.make nconstrs false in - List.iter - (function - | Cstr_constant i -> seen_const.(i) <- true - | Cstr_block i -> seen_constr.(i) <- true - | _ -> assert false) - tags; - let r = Constructor_tag_hashtbl.create (nconsts + nconstrs) in - for i = 0 to nconsts - 1 do - if not seen_const.(i) then - Constructor_tag_hashtbl.add r (Cstr_constant i) () - done; - for i = 0 to nconstrs - 1 do - if not seen_constr.(i) then Constructor_tag_hashtbl.add r (Cstr_block i) () - done; - r - (* build a pattern from a constructor list *) let pat_of_constr ex_pat cstr = { @@ -975,31 +973,17 @@ let pats_of_type ?(always = false) env ty = | Ttuple tl -> [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] | _ -> [omega] -let rec get_variant_constructors env ty = - match (Ctype.repr ty).desc with - | Tconstr (path, _, _) -> ( - try - match Env.find_type path env with - | {type_kind = Type_variant _} -> fst (Env.find_type_descrs path env) - | {type_manifest = Some _} -> - get_variant_constructors env - (Ctype.expand_head_once env (clean_copy ty)) - | _ -> fatal_error "Parmatch.get_variant_constructors" - with Not_found -> fatal_error "Parmatch.get_variant_constructors") - | _ -> fatal_error "Parmatch.get_variant_constructors" - -(* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs p all_tags = +(* Sends back the constructors of p's type matched by none of seen_constrs *) +let complete_constrs p seen_constrs = let c = match p.pat_desc with | Tpat_construct (_, c, _) -> c | _ -> assert false in - let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in let constrs = get_variant_constructors p.pat_env c.cstr_res in let others = Ext_list.filter constrs (fun cnstr -> - Constructor_tag_hashtbl.mem not_tags cnstr.cstr_tag) + not (List.exists (Types.same_constructor cnstr) seen_constrs)) in let const, nonconst = List.partition (fun cnstr -> cnstr.cstr_arity = 0) others @@ -1008,13 +992,13 @@ let complete_constrs p all_tags = let build_other_constrs env p = match p.pat_desc with - | Tpat_construct (_, {cstr_tag = Cstr_constant _ | Cstr_block _}, _) -> - let get_tag = function - | {pat_desc = Tpat_construct (_, c, _)} -> c.cstr_tag - | _ -> fatal_error "Parmatch.get_tag" + | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, _) -> + let get_constr = function + | {pat_desc = Tpat_construct (_, c, _)} -> c + | _ -> fatal_error "Parmatch.get_constr" in - let all_tags = List.map (fun (p, _) -> get_tag p) env in - pat_of_constrs p (complete_constrs p all_tags) + let seen_constrs = List.map (fun (p, _) -> get_constr p) env in + pat_of_constrs p (complete_constrs p seen_constrs) | _ -> extra_pat (* Auxiliary for build_other *) @@ -1036,7 +1020,11 @@ let some_other_tag = "" let build_other ext env : Typedtree.pattern = match env with - | ({pat_desc = Tpat_construct (lid, {cstr_tag = Cstr_extension _}, _)}, _) + | ( { + pat_desc = + Tpat_construct (lid, {cstr_identity = Extension_constructor _}, _); + }, + _ ) :: _ -> (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) @@ -1781,7 +1769,7 @@ let rec le_pat p q = | _, Tpat_alias (q, _, _) -> le_pat p q | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 | Tpat_construct (_, c1, ps), Tpat_construct (_, c2, qs) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs + Types.same_constructor c1 c2 && le_pats ps qs | Tpat_variant (l1, Some p1, _), Tpat_variant (l2, Some p2, _) -> l1 = l2 && le_pat p1 p2 | Tpat_variant (l1, None, _r1), Tpat_variant (l2, None, _) -> l1 = l2 @@ -1826,7 +1814,7 @@ let rec lub p q = let rs = lubs ps qs in make_pat (Tpat_tuple rs) p.pat_type p.pat_env | Tpat_construct (lid, c1, ps1), Tpat_construct (_, c2, ps2) - when Types.equal_tag c1.cstr_tag c2.cstr_tag -> + when Types.same_constructor c1 c2 -> let rs = lubs ps1 ps2 in make_pat (Tpat_construct (lid, c1, rs)) p.pat_type p.pat_env | Tpat_variant (l1, Some p1, row), Tpat_variant (l2, Some p2, _) when l1 = l2 @@ -2158,8 +2146,7 @@ let extendable_path path = let rec collect_paths_from_pat r p = match p.pat_desc with - | Tpat_construct - (_, {cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed}, ps) -> + | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, ps) -> let path = get_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat (if extendable_path path then add_path path r else r) @@ -2167,7 +2154,7 @@ let rec collect_paths_from_pat r p = | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> r | Tpat_tuple ps | Tpat_array ps - | Tpat_construct (_, {cstr_tag = Cstr_extension _}, ps) -> + | Tpat_construct (_, {cstr_identity = Extension_constructor _}, ps) -> List.fold_left collect_paths_from_pat r ps | Tpat_record (lps, _, _rest) -> List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps diff --git a/compiler/ml/parmatch.mli b/compiler/ml/parmatch.mli index 517206a6002..125b0022a5b 100644 --- a/compiler/ml/parmatch.mli +++ b/compiler/ml/parmatch.mli @@ -59,7 +59,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list val pat_of_constr : pattern -> constructor_description -> pattern val complete_constrs : - pattern -> constructor_tag list -> constructor_description list + pattern -> constructor_description list -> constructor_description list val ppat_of_type : Env.t -> type_expr -> diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 00812b11a31..146912d37c9 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -190,7 +190,7 @@ let decl_abstr = type_newtype_level = None; type_attributes = []; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } @@ -338,7 +338,7 @@ let common_initial_env add_type add_extension empty_env = cd_attributes = []; }; ]; - type_unboxed = Types.unboxed_true_default_false; + type_representation = Types.Transparent; } and decl_promise = let tvar = newgenvar () in diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index adbe108c1b2..545a451ba91 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -29,16 +29,20 @@ let rec struct_const ppf = function | Const_base (Const_int64 n) -> fprintf ppf "%LiL" n | Const_base (Const_bigint (sign, n)) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) - | Const_pointer (n, _) -> fprintf ppf "%ia" n + | Const_pointer (Pt_constructor {name}) -> fprintf ppf "`%s" name + | Const_pointer (Pt_variant {name}) -> fprintf ppf "`%s" name + | Const_pointer Pt_module_alias -> fprintf ppf "module_alias" + | Const_pointer Pt_shape_none -> fprintf ppf "shape_none" + | Const_pointer Pt_assertfalse -> fprintf ppf "assertfalse" | Const_block (tag_info, []) -> - let tag = Lambda.tag_of_tag_info tag_info in - fprintf ppf "[%i]" tag + let tag = Lambda.tag_label_of_tag_info tag_info in + fprintf ppf "[%s]" tag | Const_block (tag_info, sc1 :: scl) -> - let tag = Lambda.tag_of_tag_info tag_info in + let tag = Lambda.tag_label_of_tag_info tag_info in let sconsts ppf scl = List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + fprintf ppf "@[<1>[%s:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl | Const_false -> fprintf ppf "false" | Const_true -> fprintf ppf "true" @@ -326,14 +330,24 @@ let rec lam ppf = function let switch ppf sw = let spc = ref false in List.iter - (fun (n, l) -> + (fun (key, l) -> if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) + match key with + | Switch_int ordinal -> + fprintf ppf "@[case int %i:@ %a@]" ordinal lam l + | Switch_constructor (Constant {name}) -> + fprintf ppf "@[case constructor %S:@ %a@]" name lam l + | Switch_constructor (Block _) -> assert false) sw.sw_consts; List.iter - (fun (n, l) -> + (fun (key, l) -> if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) + match key with + | Switch_int ordinal -> + fprintf ppf "@[case tag %i:@ %a@]" ordinal lam l + | Switch_constructor (Block {runtime = {tag = {name}}}) -> + fprintf ppf "@[case constructor %S:@ %a@]" name lam l + | Switch_constructor (Constant _) -> assert false) sw.sw_blocks; match sw.sw_failaction with | None -> () diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 3f79ca004a8..c866693e8b5 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -896,7 +896,7 @@ and tree_of_type_decl id decl = otype_type = ty; otype_private = priv; otype_immediate = immediate; - otype_unboxed = decl.type_unboxed.unboxed || !untagged; + otype_unboxed = decl.type_representation = Transparent || !untagged; otype_cstrs = constraints; } @@ -1077,7 +1077,7 @@ let dummy = type_loc = Location.none; type_attributes = []; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index e5ae95b81c0..f0f49224745 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -133,7 +133,7 @@ let record_representation i ppf = | Record_regular -> line i ppf "Record_regular\n" | Record_float_unused -> assert false | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b - | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i + | Record_inlined {name} -> line i ppf "Record_inlined %s\n" name | Record_extension -> line i ppf "Record_extension\n" let attributes i ppf l = diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index ce96eb67ec7..d3f0dad2918 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -264,15 +264,11 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Texp_array exprs -> Use.guard (list expression env exprs) | Texp_construct (_, desc, exprs) -> let access_constructor = - match desc.cstr_tag with - | Cstr_extension pth -> Use.inspect (path env pth) + match desc.cstr_identity with + | Extension_constructor pth -> Use.inspect (path env pth) | _ -> Use.empty in - let use = - match desc.cstr_tag with - | Cstr_unboxed -> fun x -> x - | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard - in + let use = if desc.cstr_transparent then fun x -> x else Use.guard in Use.join access_constructor (use (list expression env exprs)) | Texp_variant (_, eo) -> Use.guard (option expression env eo) | Texp_record {fields = es; extended_expression = eo; representation = rep} -> diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index 9eeceac118a..b8deaf22fee 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -293,7 +293,7 @@ let type_declaration s decl = type_loc = loc s decl.type_loc; type_attributes = attrs s decl.type_attributes; type_immediate = decl.type_immediate; - type_unboxed = decl.type_unboxed; + type_representation = decl.type_representation; type_inlined_types = decl.type_inlined_types; } in diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml index 80bb69e7c52..85d3b022471 100644 --- a/compiler/ml/switch.ml +++ b/compiler/ml/switch.ml @@ -105,13 +105,7 @@ module type S = sig val make_isin : act -> act -> act val make_if : act -> act -> act -> act val make_switch : - Location.t -> - act -> - int array -> - act array -> - offset:int -> - Ast_untagged_variants.switch_names option -> - act + Location.t -> act -> int array -> act array -> offset:int -> act val make_catch : act -> int * (act -> act) val make_exit : int -> act end @@ -618,7 +612,7 @@ let rec pkey chan = function (min_clusters.(len - 1), k) (* Assume j > i *) - let make_switch loc {cases; actions} i j sw_names = + let make_switch loc {cases; actions} i j = let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in let tbl = Array.make (hh - ll + 1) 0 and t = Hashtbl.create 17 @@ -641,10 +635,9 @@ let rec pkey chan = function done; let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; - fun ctx -> - Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts sw_names + fun ctx -> Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts - let make_clusters loc ({cases; actions} as s) n_clusters k sw_names = + let make_clusters loc ({cases; actions} as s) n_clusters k = let len = Array.length cases in let r = Array.make n_clusters (0, 0, 0) and t = Hashtbl.create 17 @@ -675,7 +668,7 @@ let rec pkey chan = function else (* assert i < j *) let l, _, _ = cases.(i) and _, h, _ = cases.(j) in - r.(ir) <- (l, h, add_index (make_switch loc s i j sw_names))); + r.(ir) <- (l, h, add_index (make_switch loc s i j))); if i > 0 then zyva (i - 1) (ir - 1) in @@ -684,7 +677,7 @@ let rec pkey chan = function Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; {cases = r; actions = acts} - let do_zyva loc (low, high) arg cases actions sw_names = + let do_zyva loc (low, high) arg cases actions = let old_ok = !ok_inter in ok_inter := abs low <= inter_limit && abs high <= inter_limit; if !ok_inter <> old_ok then Hashtbl.clear t; @@ -697,7 +690,7 @@ let rec pkey chan = function prerr_endline "" ; *) let n_clusters, k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k sw_names in + let clusters = make_clusters loc s n_clusters k in c_test {arg; off = 0} clusters let abstract_shared actions = @@ -716,11 +709,11 @@ let rec pkey chan = function in (!handlers, actions) - let zyva loc lh arg cases actions names = + let zyva loc lh arg cases actions = assert (Array.length cases > 0); let actions = actions.act_get_shared () in let hs, actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions names) + hs (do_zyva loc lh arg cases actions) and test_sequence arg cases actions = assert (Array.length cases > 0); diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli index 89bce4107df..2b3b5e7c178 100644 --- a/compiler/ml/switch.mli +++ b/compiler/ml/switch.mli @@ -80,13 +80,7 @@ module type S = sig make_switch arg cases acts NB: cases is in the value form *) val make_switch : - Location.t -> - act -> - int array -> - act array -> - offset:int -> - Ast_untagged_variants.switch_names option -> - act + Location.t -> act -> int array -> act array -> offset:int -> act (* Build last minute sharing of action stuff *) val make_catch : act -> int * (act -> act) @@ -111,7 +105,6 @@ module Make : functor (Arg : S) -> sig Arg.act -> (int * int * int) array -> Arg.act t_store -> - Ast_untagged_variants.switch_names option -> Arg.act (* Output test sequence, sharing tracked *) diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index f19f827aa74..15e98ce015a 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -21,25 +21,31 @@ let undefined_location loc = Const_base (Const_int char); ] )) -let cstr_const = 3 - -let cstr_non_const = 2 - let init_shape modl = let add_name x id = Const_block (Blk_tuple, [x; Const_base (Const_string (Ident.name id, None))]) in let module_tag_info : Lambda.tag_info = - Blk_constructor {name = "Module"; num_nonconst = 2; tag = 0; attrs = []} + Blk_constructor + { + name = "Module"; + num_nonconst = 2; + runtime = Ast_untagged_variants.block_runtime ~name:"Module" []; + } in let value_tag_info : Lambda.tag_info = - Blk_constructor {name = "value"; num_nonconst = 2; tag = 1; attrs = []} + Blk_constructor + { + name = "value"; + num_nonconst = 2; + runtime = Ast_untagged_variants.block_runtime ~name:"value" []; + } in let rec init_shape_mod env mty = match Mtype.scrape env mty with | Mty_ident _ -> raise Not_found | Mty_alias _ -> - Const_block (value_tag_info, [Const_pointer (0, Pt_module_alias)]) + Const_block (value_tag_info, [Const_pointer Pt_module_alias]) | Mty_signature sg -> Const_block (module_tag_info, [Const_block (Blk_tuple, init_shape_struct env sg)]) @@ -58,14 +64,8 @@ let init_shape modl = match Ctype.expand_head env ty with | t when is_function t -> Const_pointer - ( 0, - Pt_constructor - { - name = "Function"; - const = cstr_const; - non_const = cstr_non_const; - attrs = []; - } ) + (Pt_constructor + (Ast_untagged_variants.constructor_tag ~name:"Function" [])) | _ -> raise Not_found in add_name init_v id :: init_shape_struct env rem diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 6a55f5d0264..38697eeb5ed 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -34,6 +34,21 @@ let transl_module = (fun _cc _rootpath _modl -> assert false : module_coercion -> Path.t option -> module_expr -> lambda) +(* Number of payload-carrying constructors of the variant declaring + [cstr]; part of the runtime representation of its blocks *) +let num_nonconst_constructors env (cstr : Types.constructor_description) = + match cstr.cstr_identity with + | Ordinary_constructor {type_path} -> ( + match (Env.find_type type_path env).type_kind with + | Type_variant cstrs -> + List.length + (List.filter + (fun (cd : Types.constructor_declaration) -> + cd.cd_args <> Cstr_tuple []) + cstrs) + | _ -> assert false) + | Extension_constructor _ -> assert false + (* Compile an exception/extension definition *) let transl_extension_constructor env path ext = @@ -520,10 +535,24 @@ let transl_primitive_application loc prim env ty args = let has_constant_constructor = match args with | [ - _; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; + _; + { + exp_desc = + Texp_construct + ( _, + {cstr_identity = Ordinary_constructor _; cstr_args = []}, + _ ); + }; ] | [ - {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _; + { + exp_desc = + Texp_construct + ( _, + {cstr_identity = Ordinary_constructor _; cstr_args = []}, + _ ); + }; + _; ] | [_; {exp_desc = Texp_variant (_, None)}] | [{exp_desc = Texp_variant (_, None)}; _] -> @@ -744,60 +773,52 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true - | Texp_construct (lid, cstr, args) -> ( + | Texp_construct (_, cstr, args) -> ( let ll = transl_list args in if cstr.cstr_inlined <> None then match ll with | [x] -> x | _ -> assert false else - match cstr.cstr_tag with - | Cstr_constant n -> + match cstr.cstr_identity with + | Ordinary_constructor _ when cstr.cstr_args = [] -> Lconst (Const_pointer - ( n, - match lid.txt with - | Longident.Ldot (Longident.Lident "*predef*", "None") - | Longident.Lident "None" - when Datarepr.constructor_has_optional_shape cstr -> - Pt_shape_none - | _ -> - if Datarepr.constructor_has_optional_shape cstr then - Pt_shape_none - else - Pt_constructor - { - name = cstr.cstr_name; - const = cstr.cstr_consts; - non_const = cstr.cstr_nonconsts; - attrs = cstr.cstr_attributes; - } )) - | Cstr_unboxed -> ( - match ll with - | [v] -> v - | _ -> assert false) - | Cstr_block n -> ( - let tag_info : Lambda.tag_info = - if Datarepr.constructor_has_optional_shape cstr then - match args with - | [arg] - when Typeopt.type_cannot_contain_undefined arg.exp_type - arg.exp_env -> - (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) - Blk_some_not_nested - | _ -> Blk_some - else - Blk_constructor - { - name = cstr.cstr_name; - num_nonconst = cstr.cstr_nonconsts; - tag = n; - attrs = cstr.cstr_attributes; - } + (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none + else + Pt_constructor + (Ast_untagged_variants.constructor_tag ~name:cstr.cstr_name + cstr.cstr_attributes))) + | Ordinary_constructor _ -> ( + let runtime = + Ast_untagged_variants.block_runtime ~name:cstr.cstr_name + cstr.cstr_attributes in - try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) - | Cstr_extension path -> + if cstr.cstr_transparent then + match ll with + | [value] -> value + | _ -> assert false + else + let tag_info : Lambda.tag_info = + if Datarepr.constructor_has_optional_shape cstr then + match args with + | [arg] + when Typeopt.type_cannot_contain_undefined arg.exp_type + arg.exp_env -> + (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) + Blk_some_not_nested + | _ -> Blk_some + else + Blk_constructor + { + name = cstr.cstr_name; + num_nonconst = num_nonconst_constructors e.exp_env cstr; + runtime; + } + in + try Lconst (Const_block (tag_info, List.map extract_constant ll)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + | Extension_constructor path -> Lprim ( Pmakeblock Blk_extension, transl_extension_path e.exp_env path :: ll, @@ -806,7 +827,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_variant (l, arg) -> ( let tag = Btype.hash_variant l in match arg with - | None -> Lconst (Const_pointer (tag, Pt_variant {name = l})) + | None -> Lconst (Const_pointer (Pt_variant {name = l})) | Some arg -> ( let lam = transl_exp arg in let tag_info = Blk_poly_var l in @@ -1108,11 +1129,12 @@ and transl_record loc env fields repres opt_init_expr = | Record_float_unused -> assert false | Record_regular -> Lconst (Const_block (Lambda.blk_record fields mut, cl)) - | Record_inlined {tag; name; num_nonconsts; attrs} -> + | Record_inlined {name; num_nonconsts; attrs} -> Lconst (Const_block - ( Lambda.blk_record_inlined fields name num_nonconsts ~tag - ~attrs mut, + ( Lambda.blk_record_inlined fields name num_nonconsts + ~runtime:(Ast_untagged_variants.block_runtime ~name attrs) + mut, cl )) | Record_unboxed _ -> Lconst @@ -1125,11 +1147,12 @@ and transl_record loc env fields repres opt_init_expr = | Record_regular -> Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) | Record_float_unused -> assert false - | Record_inlined {tag; name; num_nonconsts; attrs} -> + | Record_inlined {name; num_nonconsts; attrs} -> Lprim ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts ~tag - ~attrs mut), + (Lambda.blk_record_inlined fields name num_nonconsts + ~runtime:(Ast_untagged_variants.block_runtime ~name attrs) + mut), ll, loc ) | Record_unboxed _ -> ( diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index d80d100e2b2..14182f2630b 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3450,8 +3450,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp }; ] -> let path = - match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with - | Cstr_extension path -> path + match (Typetexp.find_constructor env lid.loc lid.txt).cstr_identity with + | Extension_constructor path -> path | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) in rue @@ -3494,7 +3494,7 @@ and type_newtype ~loc ~env ~name (type_body : Env.t -> Typedtree.expression) = type_loc = loc; type_attributes = []; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 9e3fc917a8a..13cb11d95ba 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -60,18 +60,13 @@ open Typedtree exception Error of Location.t * error -(* Note: do not factor the branches in the following pattern-matching: - the records must be constants for the compiler to do sharing on them. -*) -let get_unboxed_from_attributes sdecl = +let get_representation_from_attributes sdecl = let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in - match (boxed, unboxed, !Clflags.unboxed_types) with - | true, true, _ -> raise (Error (sdecl.ptype_loc, Boxed_and_unboxed)) - | true, false, _ -> unboxed_false_default_false - | false, true, _ -> unboxed_true_default_false - | false, false, false -> unboxed_false_default_true - | false, false, true -> unboxed_true_default_true + match (boxed, unboxed) with + | true, true -> raise (Error (sdecl.ptype_loc, Boxed_and_unboxed)) + | true, false | false, false -> Boxed + | false, true -> Transparent (* Enter all declared types in the environment as abstract types *) @@ -106,7 +101,7 @@ let enter_type rec_flag env sdecl id = type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } in @@ -138,7 +133,7 @@ let rec get_unboxed_type_representation env ty fuel = | Tconstr (p, args, _) -> ( match Env.find_type p env with | exception Not_found -> Some ty - | {type_unboxed = {unboxed = false}} -> Some ty + | {type_representation = Boxed} -> Some ty | { type_params; type_kind = @@ -399,7 +394,7 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = loc )) sdecl.ptype_cstrs in - let raw_status = get_unboxed_from_attributes sdecl in + let raw_status = get_representation_from_attributes sdecl in let check_untagged_variant () = match sdecl.ptype_kind with @@ -415,10 +410,7 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = | _ -> false in - (if - raw_status.unboxed && (not raw_status.default) - && not (check_untagged_variant ()) - then + (if raw_status = Transparent && not (check_untagged_variant ()) then match sdecl.ptype_kind with | Ptype_abstract -> raise (Error (sdecl.ptype_loc, Bad_unboxed_attribute "it is abstract")) @@ -436,10 +428,9 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = ( sdecl.ptype_loc, Bad_unboxed_attribute "extensible variant types cannot be unboxed" ))); - let unboxed_status = + let representation = match sdecl.ptype_kind with - | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> - unboxed_false_default_false + | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> Boxed | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable = Immutable; _}]; _}] @@ -447,9 +438,9 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = raw_status | _ -> (* The type is not unboxable, mark it as boxed *) - unboxed_false_default_false + Boxed in - let unbox = unboxed_status.unboxed in + let unbox = representation = Transparent in let tkind, kind, sdecl = match sdecl.ptype_kind with | Ptype_abstract -> (Ttype_abstract, Type_abstract, sdecl) @@ -713,7 +704,7 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = false; - type_unboxed = unboxed_status; + type_representation = representation; type_inlined_types = []; } in @@ -1332,7 +1323,7 @@ let compute_immediacy env tdecl = | Type_variant [{cd_args = Cstr_tuple [arg]; _}], _ | Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _ | Type_record ([{ld_type = arg; _}], _), _ - when tdecl.type_unboxed.unboxed -> ( + when tdecl.type_representation = Transparent -> ( match get_unboxed_type_representation env arg with | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) | None -> false) @@ -1690,8 +1681,8 @@ let transl_extension_constructor env type_path type_params typext_params priv | Private, Public -> raise (Error (lid.loc, Rebind_private lid.txt)) | _ -> ()); let path = - match cdescr.cstr_tag with - | Cstr_extension path -> path + match cdescr.cstr_identity with + | Extension_constructor path -> path | _ -> assert false in let args = @@ -1975,9 +1966,10 @@ let transl_with_constraint env id row_path orig_decl sdecl = && orig_decl.type_kind <> Type_abstract && sdecl.ptype_private = Private then Location.deprecated sdecl.ptype_loc "spurious use of private"; - let type_kind, type_unboxed = - if arity_ok && man <> None then (orig_decl.type_kind, orig_decl.type_unboxed) - else (Type_abstract, unboxed_false_default_false) + let type_kind, type_representation = + if arity_ok && man <> None then + (orig_decl.type_kind, orig_decl.type_representation) + else (Type_abstract, Boxed) in let decl = { @@ -1991,7 +1983,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = false; - type_unboxed; + type_representation; type_inlined_types = []; } in @@ -2042,7 +2034,7 @@ let abstract_type_decl arity = type_loc = Location.none; type_attributes = []; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } in diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml index b35814fe62c..e5f6d73481a 100644 --- a/compiler/ml/typemod.ml +++ b/compiler/ml/typemod.ml @@ -333,7 +333,7 @@ let merge_constraint initial_env loc sg constr = type_newtype_level = None; type_attributes = []; type_immediate = false; - type_unboxed = unboxed_false_default_false; + type_representation = Boxed; type_inlined_types = []; } and id_row = Ident.create (s ^ "#row") in diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 409961eaaf1..d4672623a18 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -23,7 +23,7 @@ let scrape_ty env ty = match ty.desc with | Tconstr (p, _, _) -> ( match Env.find_type p env with - | {type_unboxed = {unboxed = true; _}; _} -> ( + | {type_representation = Transparent; _} -> ( match Typedecl.get_unboxed_type_representation env ty with | None -> ty | Some ty2 -> ty2) diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 2f9acf327d6..d1a2805beea 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -133,7 +133,7 @@ type type_declaration = { type_loc: Location.t; type_attributes: Parsetree.attributes; type_immediate: bool; - type_unboxed: unboxed_status; + type_representation: type_representation; type_inlined_types: type_inlined_type list; } @@ -153,7 +153,6 @@ and record_representation = | Record_inlined of (* Inlined record *) { - tag: int; name: string; num_nonconsts: int; attrs: Parsetree.attributes; @@ -181,15 +180,9 @@ and constructor_arguments = | Cstr_tuple of type_expr list | Cstr_record of label_declaration list -and unboxed_status = { - unboxed: bool; - default: bool; (* False if the unboxed field was set from an attribute. *) -} - -let unboxed_false_default_false = {unboxed = false; default = false} -let unboxed_false_default_true = {unboxed = false; default = true} -let unboxed_true_default_false = {unboxed = true; default = false} -let unboxed_true_default_true = {unboxed = true; default = true} +and type_representation = Boxed | Transparent +(* Single-payload @unboxed type: the payload is the whole runtime + value. Untagged unions are tracked by their attributes, not here. *) type extension_constructor = { ext_type_path: Path.t; @@ -256,9 +249,10 @@ type constructor_description = { cstr_existentials: type_expr list; (* list of existentials *) cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_identity: constructor_identity; (* Semantic identity *) + cstr_transparent: bool; + (* Sole payload-carrying constructor of an unboxed type: constructing + it is the identity at runtime *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; @@ -266,25 +260,33 @@ type constructor_description = { cstr_inlined: type_declaration option; } -and constructor_tag = - | Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_unboxed (* Constructor of an unboxed type *) - | Cstr_extension of Path.t (* Extension constructor *) - -let equal_tag t1 t2 = - match (t1, t2) with - | Cstr_constant i1, Cstr_constant i2 -> i2 = i1 - | Cstr_block i1, Cstr_block i2 -> i2 = i1 - | Cstr_unboxed, Cstr_unboxed -> true - | Cstr_extension path1, Cstr_extension path2 -> Path.same path1 path2 - | (Cstr_constant _ | Cstr_block _ | Cstr_unboxed | Cstr_extension _), _ -> - false +and constructor_identity = + | Ordinary_constructor of {type_path: Path.t; name: string} + (* Constructor introduced by a variant type declaration. The path is + the path of the declaring type as written, so a re-exported variant + (type u = M.t = A | B) yields descriptions carrying the + re-exporting type's path. *) + | Extension_constructor of Path.t (* Extension constructor *) + +(* Whether two constructor descriptions denote the same constructor of a + common scrutinee type. Because a re-exported variant mints descriptions + with a different type path, ordinary constructors are compared by name + only; the shared scrutinee type makes the name unambiguous. Not a + general-purpose identity test across unrelated types. *) +let same_constructor c1 c2 = + match (c1.cstr_identity, c2.cstr_identity) with + | Ordinary_constructor {name = n1}, Ordinary_constructor {name = n2} -> + n1 = n2 + | Extension_constructor p1, Extension_constructor p2 -> Path.same p1 p2 + | (Ordinary_constructor _ | Extension_constructor _), _ -> false let may_equal_constr c1 c2 = - match (c1.cstr_tag, c2.cstr_tag) with - | Cstr_extension _, Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity - | tag1, tag2 -> equal_tag tag1 tag2 + match (c1.cstr_identity, c2.cstr_identity) with + | Extension_constructor _, Extension_constructor _ -> + (* extension constructors may be rebound, so paths cannot disprove + equality; arity can *) + c1.cstr_arity = c2.cstr_arity + | _ -> same_constructor c1 c2 type label_description = { lbl_name: string; (* Short name *) @@ -304,10 +306,9 @@ let same_record_representation x y = match x with | Record_regular -> y = Record_regular | Record_float_unused -> y = Record_float_unused - | Record_inlined {tag; name; num_nonconsts} -> ( + | Record_inlined {name; num_nonconsts} -> ( match y with - | Record_inlined y -> - tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts + | Record_inlined y -> name = y.name && num_nonconsts = y.num_nonconsts | _ -> false) | Record_extension -> y = Record_extension | Record_unboxed x -> ( diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index a18eb2ac2f0..8afc111b1a9 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -238,7 +238,7 @@ type type_declaration = { type_loc: Location.t; type_attributes: Parsetree.attributes; type_immediate: bool; (* true iff type should not be a pointer *) - type_unboxed: unboxed_status; + type_representation: type_representation; type_inlined_types: type_inlined_type list; (** Representation of inlined types, needed for printing *) } @@ -259,7 +259,6 @@ and record_representation = | Record_inlined of (* Inlined record *) { - tag: int; name: string; num_nonconsts: int; attrs: Parsetree.attributes; @@ -287,19 +286,9 @@ and constructor_arguments = | Cstr_tuple of type_expr list | Cstr_record of label_declaration list -and unboxed_status = - private - (* This type must be private in order to ensure perfect sharing of the - four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce - different executables. *) { - unboxed: bool; - default: bool; (* True for unannotated unboxable types. *) -} - -val unboxed_false_default_false : unboxed_status -val unboxed_false_default_true : unboxed_status -val unboxed_true_default_false : unboxed_status -val unboxed_true_default_true : unboxed_status +and type_representation = Boxed | Transparent +(* Single-payload @unboxed type: the payload is the whole runtime + value. Untagged unions are tracked by their attributes, not here. *) type extension_constructor = { ext_type_path: Path.t; @@ -364,9 +353,10 @@ type constructor_description = { cstr_existentials: type_expr list; (* list of existentials *) cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_identity: constructor_identity; (* Semantic identity *) + cstr_transparent: bool; + (* Sole payload-carrying constructor of an unboxed type: constructing + it is the identity at runtime *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; @@ -374,14 +364,20 @@ type constructor_description = { cstr_inlined: type_declaration option; } -and constructor_tag = - | Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_unboxed (* Constructor of an unboxed type *) - | Cstr_extension of Path.t (* Extension constructor *) - -(* Constructors are the same *) -val equal_tag : constructor_tag -> constructor_tag -> bool +and constructor_identity = + | Ordinary_constructor of {type_path: Path.t; name: string} + (* Constructor introduced by a variant type declaration. The path is + the path of the declaring type as written, so a re-exported variant + (type u = M.t = A | B) yields descriptions carrying the + re-exporting type's path. *) + | Extension_constructor of Path.t (* Extension constructor *) + +(* Constructor descriptions of a common scrutinee type denote the same + constructor: ordinary constructors compare by name (re-exported variants + carry a different type path), extension constructors by path. Not a + general-purpose identity test across unrelated types. *) +val same_constructor : + constructor_description -> constructor_description -> bool (* Constructors may be the same, given potential rebinding *) val may_equal_constr : diff --git a/packages/@rescript/runtime/Primitive_js_extern.res b/packages/@rescript/runtime/Primitive_js_extern.res index 3d028e71e86..08444d88e42 100644 --- a/packages/@rescript/runtime/Primitive_js_extern.res +++ b/packages/@rescript/runtime/Primitive_js_extern.res @@ -1,5 +1,3 @@ -@@config({flags: ["-unboxed-types"]}) - @unboxed type null<+'a> = Value('a) | @as(null) Null @@ -36,26 +34,26 @@ external ge: ('a, 'a) => bool = "%unsafe_ge" external unsafe_to_method: 'a => 'a = "%unsafe_to_method" module Callback = { - type arity1<'a> = {@internal i1: 'a} - type arity2<'a> = {@internal i2: 'a} - type arity3<'a> = {@internal i3: 'a} - type arity4<'a> = {@internal i4: 'a} - type arity5<'a> = {@internal i5: 'a} - type arity6<'a> = {@internal i6: 'a} - type arity7<'a> = {@internal i7: 'a} - type arity8<'a> = {@internal i8: 'a} - type arity9<'a> = {@internal i9: 'a} - type arity10<'a> = {@internal i10: 'a} - type arity11<'a> = {@internal i11: 'a} - type arity12<'a> = {@internal i12: 'a} - type arity13<'a> = {@internal i13: 'a} - type arity14<'a> = {@internal i14: 'a} - type arity15<'a> = {@internal i15: 'a} - type arity16<'a> = {@internal i16: 'a} - type arity17<'a> = {@internal i17: 'a} - type arity18<'a> = {@internal i18: 'a} - type arity19<'a> = {@internal i19: 'a} - type arity20<'a> = {@internal i20: 'a} - type arity21<'a> = {@internal i21: 'a} - type arity22<'a> = {@internal i22: 'a} + @unboxed type arity1<'a> = {@internal i1: 'a} + @unboxed type arity2<'a> = {@internal i2: 'a} + @unboxed type arity3<'a> = {@internal i3: 'a} + @unboxed type arity4<'a> = {@internal i4: 'a} + @unboxed type arity5<'a> = {@internal i5: 'a} + @unboxed type arity6<'a> = {@internal i6: 'a} + @unboxed type arity7<'a> = {@internal i7: 'a} + @unboxed type arity8<'a> = {@internal i8: 'a} + @unboxed type arity9<'a> = {@internal i9: 'a} + @unboxed type arity10<'a> = {@internal i10: 'a} + @unboxed type arity11<'a> = {@internal i11: 'a} + @unboxed type arity12<'a> = {@internal i12: 'a} + @unboxed type arity13<'a> = {@internal i13: 'a} + @unboxed type arity14<'a> = {@internal i14: 'a} + @unboxed type arity15<'a> = {@internal i15: 'a} + @unboxed type arity16<'a> = {@internal i16: 'a} + @unboxed type arity17<'a> = {@internal i17: 'a} + @unboxed type arity18<'a> = {@internal i18: 'a} + @unboxed type arity19<'a> = {@internal i19: 'a} + @unboxed type arity20<'a> = {@internal i20: 'a} + @unboxed type arity21<'a> = {@internal i21: 'a} + @unboxed type arity22<'a> = {@internal i22: 'a} } From ed3b34df8e2b67b989cd759514735128c9eb704a Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 21 Aug 2026 16:38:38 +0200 Subject: [PATCH 2/7] Store the canonical variant layout on type declarations Introduce Variant_runtime, a leaf module below Types holding the plain data that describes how variants are represented in JavaScript; Ast_untagged_variants re-exports the definitions and keeps deriving them. Type_variant now carries the canonical layout, mirroring how Type_record carries record_representation: typedecl computes it once the recursive group is in the environment, at the same point the untagged invariants were already being validated by computing this exact layout and discarding it. Predefined declarations mint their layouts by hand, and the untagged helper refs are installed from Typedecl so every binary that types code has them. The stored layout is not consumed yet; matching still derives its own. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01YWw5GW8t4UDEWAzoqcDMkE --- analysis/reanalyze/src/dead_type.ml | 2 +- analysis/src/hover.ml | 2 +- analysis/src/process_cmt.ml | 2 +- compiler/core/matching_polyfill.ml | 5 - .../gentype/translate_signature_from_types.ml | 2 +- .../gentype/translate_type_declarations.ml | 2 +- compiler/ml/ast_untagged_variants.ml | 91 +++--------- compiler/ml/btype.ml | 2 +- compiler/ml/ctype.ml | 39 +++-- compiler/ml/datarepr.ml | 2 +- compiler/ml/error_message_utils.ml | 2 +- compiler/ml/includecore.ml | 2 +- compiler/ml/matching.ml | 2 +- compiler/ml/parmatch.ml | 2 +- compiler/ml/predef.ml | 24 ++- compiler/ml/printtyp.ml | 6 +- compiler/ml/subst.ml | 4 +- compiler/ml/translcore.ml | 2 +- compiler/ml/typecore.ml | 4 +- compiler/ml/typedecl.ml | 70 +++++---- compiler/ml/typeopt.ml | 21 +-- compiler/ml/types.ml | 3 +- compiler/ml/types.mli | 3 +- compiler/ml/variant_coercion.ml | 6 +- compiler/ml/variant_runtime.ml | 139 ++++++++++++++++++ compiler/ml/variant_type_spread.ml | 6 +- 26 files changed, 289 insertions(+), 156 deletions(-) create mode 100644 compiler/ml/variant_runtime.ml diff --git a/analysis/reanalyze/src/dead_type.ml b/analysis/reanalyze/src/dead_type.ml index 1bfad3e33a3..d0eeb449d03 100644 --- a/analysis/reanalyze/src/dead_type.ml +++ b/analysis/reanalyze/src/dead_type.ml @@ -39,7 +39,7 @@ let add_declaration ~config ~decls ~file ~(module_path : Module_path.t) Ident.name ld_id |> Name.create |> process_type_label ~decl_kind:RecordLabel ~loc:ld_loc) l - | Type_variant decls -> + | Type_variant (decls, _) -> List.iteri (fun i {Types.cd_id; cd_loc; cd_args} -> let _handle_inline_records = diff --git a/analysis/src/hover.ml b/analysis/src/hover.ml index 66c35d1934d..e59ca1da0dd 100644 --- a/analysis/src/hover.ml +++ b/analysis/src/hover.ml @@ -82,7 +82,7 @@ let find_relevant_types_from_type ~state ~file ~package typ = match decl.type_kind with | Type_record (lds, _) -> (env1, typ :: (lds |> label_declarations_types)) - | Type_variant cds -> + | Type_variant (cds, _) -> ( env1, cds |> List.map (fun (cd : Types.constructor_declaration) -> diff --git a/analysis/src/process_cmt.ml b/analysis/src/process_cmt.ml index 1a6c0dd2367..0ec4a4fd7b2 100644 --- a/analysis/src/process_cmt.ml +++ b/analysis/src/process_cmt.ml @@ -90,7 +90,7 @@ let rec for_type_signature_item ~(env : Shared_types.Env.t) (* TODO dig *) | _ -> Abstract None) | Type_open -> Open - | Type_variant constructors -> + | Type_variant (constructors, _) -> Variant (constructors |> List.map diff --git a/compiler/core/matching_polyfill.ml b/compiler/core/matching_polyfill.ml index 0188a0cc9ce..723b7dd4a9e 100644 --- a/compiler/core/matching_polyfill.ml +++ b/compiler/core/matching_polyfill.ml @@ -22,11 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let () = - Ast_untagged_variants.extract_concrete_typedecl := - Ctype.extract_concrete_typedecl -let () = Ast_untagged_variants.expand_head := Ctype.expand_head - (** Note it is a bit tricky when there is unbound var, its type will be Tvar which is too complicated to support subtyping diff --git a/compiler/gentype/translate_signature_from_types.ml b/compiler/gentype/translate_signature_from_types.ml index 72102774f85..64d37058abf 100644 --- a/compiler/gentype/translate_signature_from_types.ml +++ b/compiler/gentype/translate_signature_from_types.ml @@ -14,7 +14,7 @@ let translate_type_declaration_from_types ~config ~output_file_relative match type_kind with | Type_record (label_declarations, _) -> Translate_type_declarations.RecordDeclarationFromTypes label_declarations - | Type_variant constructor_declarations + | Type_variant (constructor_declarations, _) when not (Translate_type_declarations.has_some_gadt_leaf constructor_declarations) -> diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index e10cf39dc9a..1167bca692a 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -341,7 +341,7 @@ let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env match typ_type.type_kind with | Type_record (label_declarations, _) -> RecordDeclarationFromTypes label_declarations - | Type_variant constructor_declarations -> + | Type_variant (constructor_declarations, _) -> VariantDeclarationFromTypes constructor_declarations | Type_abstract -> GeneralDeclaration typ_manifest | _ -> NoDeclaration diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 068c8053ad5..e36f110119c 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -1,53 +1,4 @@ -module Instance = struct - type t = - | Array - | ArrayBuffer - | BigInt64Array - | BigUint64Array - | Blob - | DataView - | Date - | File - | Float32Array - | Float64Array - | Int16Array - | Int32Array - | Int8Array - | Promise - | RegExp - | Uint16Array - | Uint32Array - | Uint8Array - | Uint8ClampedArray - | Set - | Map - | WeakSet - | WeakMap - let to_string = function - | Array -> "Array" - | ArrayBuffer -> "ArrayBuffer" - | BigInt64Array -> "BigInt64Array" - | BigUint64Array -> "BigUint64Array" - | Blob -> "Blob" - | DataView -> "DataView" - | Date -> "Date" - | File -> "File" - | Float32Array -> "Float32Array" - | Float64Array -> "Float64Array" - | Int16Array -> "Int16Array" - | Int32Array -> "Int32Array" - | Int8Array -> "Int8Array" - | Promise -> "Promise" - | RegExp -> "RegExp" - | Uint16Array -> "Uint16Array" - | Uint32Array -> "Uint32Array" - | Uint8Array -> "Uint8Array" - | Uint8ClampedArray -> "Uint8ClampedArray" - | Set -> "Set" - | Map -> "Map" - | WeakSet -> "WeakSet" - | WeakMap -> "WeakMap" -end +module Instance = Variant_runtime.Instance type untagged_error = | OnlyOneUnknown of string @@ -107,8 +58,7 @@ let report_error ppf = rename the field." constructor_name runtime_value field_name -(* Type of the runtime representation of an untagged block (case with payoad) *) -type block_type = +type block_type = Variant_runtime.block_type = | IntType | StringType | FloatType @@ -135,7 +85,7 @@ let block_type_to_user_visible_string = function Can be a literal (case with no payload), or a block (case with payload). In the case of block it can be tagged or untagged. *) -type tag_type = +type tag_type = Variant_runtime.tag_type = | String of string | Int of int | Float of string @@ -144,25 +94,34 @@ type tag_type = | Null | Undefined (* literal or tagged block *) | Untagged of block_type (* untagged block *) -type tag = {name: string; tag_type: tag_type option} +type tag = Variant_runtime.tag = {name: string; tag_type: tag_type option} -type block_runtime = {tag: tag; tag_name: string option; untagged: bool} +type block_runtime = Variant_runtime.block_runtime = { + tag: tag; + tag_name: string option; + untagged: bool; +} (** Runtime information shared by construction and pattern matching for a constructor carrying a payload. [block_type] is deliberately not part of this value: it describes how a matcher recognizes an unboxed payload, not how the value itself is constructed. *) -type block = {runtime: block_runtime; block_type: block_type option} +type block = Variant_runtime.block = { + runtime: block_runtime; + block_type: block_type option; +} -type constructor_case = Constant of tag | Block of block +type constructor_case = Variant_runtime.constructor_case = + | Constant of tag + | Block of block -type variant_layout = { +type variant_layout = Variant_runtime.variant_layout = { constructors: constructor_case array; constructors_by_name: (int * constructor_case) Map_string.t; } (** Canonical runtime layout in source-constructor order. *) -type variant_dispatch = { +type variant_dispatch = Variant_runtime.variant_dispatch = { tag_name: string option; block_types: block_type list; literal_tags: tag_type list; @@ -251,6 +210,9 @@ let process_untagged (attrs : Parsetree.attributes) = | _ -> ()); !st +(* Filled in by [Typedecl] to break the module cycle through [Ctype]; + installed at module initialization of the typing layer, so they are set + before any declaration is typed. *) let extract_concrete_typedecl : (Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration) ref = ref (Obj.magic ()) @@ -529,7 +491,7 @@ let constructor_declaration_from_constructor_description ~env match cd.cstr_res.desc with | Tconstr (path, _, _) -> ( match Env.find_type path env with - | {type_kind = Type_variant cstrs} -> + | {type_kind = Type_variant (cstrs, _)} -> Ext_list.find_opt cstrs (fun cstr -> if cstr.cd_id.name = cd.cstr_name then Some cstr else None) | _ -> None) @@ -609,15 +571,6 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = | _ -> ()) cstrs -type well_formedness_check = { - is_untagged_def: bool; - cstrs: Types.constructor_declaration list; -} - -let check_well_formed ~env {is_untagged_def; cstrs} = - check_tag_field_conflicts cstrs; - ignore (layout_from_type_variant ~env ~is_untagged_def cstrs) - let has_undefined_literal attrs = process_tag_type attrs = Some Undefined let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml index 5e99ff5a3ad..ca64115aae1 100644 --- a/compiler/ml/btype.ml +++ b/compiler/ml/btype.ml @@ -313,7 +313,7 @@ let map_type_expr_cstr_args f = function let iter_type_expr_kind f = function | Type_abstract -> () - | Type_variant cstrs -> + | Type_variant (cstrs, _) -> List.iter (fun cd -> iter_type_expr_cstr_args f cd.cd_args; diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 7f3913e84a5..0ace5e8ddf2 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -430,7 +430,7 @@ let closed_type_decl decl = List.iter mark_type decl.type_params; (match decl.type_kind with | Type_abstract -> () - | Type_variant v -> + | Type_variant (v, _) -> List.iter (fun {cd_args; cd_res; _} -> match cd_res with @@ -946,16 +946,17 @@ let instance_parameterized_type ?keep_names sch_args sch = let map_kind f = function | Type_abstract -> Type_abstract | Type_open -> Type_open - | Type_variant cl -> + | Type_variant (cl, layout) -> Type_variant - (List.map - (fun c -> - { - c with - cd_args = map_type_expr_cstr_args f c.cd_args; - cd_res = may_map f c.cd_res; - }) - cl) + ( List.map + (fun c -> + { + c with + cd_args = map_type_expr_cstr_args f c.cd_args; + cd_res = may_map f c.cd_res; + }) + cl, + layout ) | Type_record (fl, rr) -> Type_record (List.map (fun l -> {l with ld_type = f l.ld_type}) fl, rr) @@ -1900,7 +1901,7 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = when Types.same_record_representation r r' -> mcomp_list type_pairs env tl1 tl2; mcomp_record_description type_pairs env lst lst' - | Type_variant v1, Type_variant v2 -> + | Type_variant (v1, _), Type_variant (v2, _) -> mcomp_list type_pairs env tl1 tl2; mcomp_variant_description type_pairs env v1 v2 | Type_open, Type_open -> mcomp_list type_pairs env tl1 tl2 @@ -3571,8 +3572,12 @@ let rec subtype_rec env trace t1 t2 cstrs = match (extract_concrete_typedecl env t1, extract_concrete_typedecl env t2) with - | ( (p1, _, {type_kind = Type_variant c1; type_attributes = t1attrs}), - (p2, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) ) + | ( ( p1, + _, + {type_kind = Type_variant (c1, _); type_attributes = t1attrs} ), + ( p2, + _, + {type_kind = Type_variant (c2, _); type_attributes = t2attrs} ) ) -> ( match Variant_coercion.variant_configuration_can_be_coerced t1attrs @@ -3756,8 +3761,12 @@ let rec subtype_rec env trace t1 t2 cstrs = |> Variant_coercion.type_is_variant -> ( (* TODO(subtype-errors) Polyvariant to variant *) match extract_concrete_typedecl env t2 with - | _, _, {type_kind = Type_variant variant_constructors; type_attributes} - -> ( + | ( _, + _, + { + type_kind = Type_variant (variant_constructors, _); + type_attributes; + } ) -> ( match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~type_attributes diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 54184b453d0..72ca2017940 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -249,7 +249,7 @@ let label_descrs ty_res lbls repres priv = let constructors_of_type ty_path decl = match decl.type_kind with - | Type_variant cstrs -> constructor_descrs ty_path decl cstrs + | Type_variant (cstrs, _) -> constructor_descrs ty_path decl cstrs | Type_record _ | Type_abstract | Type_open -> [] let labels_of_type ty_path decl = diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 76867174493..c9bee3e5f86 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -217,7 +217,7 @@ let is_jsx_component_type ~env ty = let get_variant_constructors ~(extract_concrete_typedecl : extract_concrete_typedecl) ~env ty = match extract_concrete_typedecl env ty with - | _, _, {Types.type_kind = Type_variant constructors; _} -> constructors + | _, _, {Types.type_kind = Type_variant (constructors, _); _} -> constructors | _ -> [] let extract_string_constant text = diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 62798636473..34f7913337d 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -374,7 +374,7 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = let err = match (decl1.type_kind, decl2.type_kind) with | _, Type_abstract -> [] - | Type_variant cstrs1, Type_variant cstrs2 -> + | Type_variant (cstrs1, _), Type_variant (cstrs2, _) -> let mark cstrs usage name decl = List.iter (fun c -> diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 635e63fa1da..8916048d707 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2462,7 +2462,7 @@ let arg_to_var arg cls = let layout_from_construct_pattern (pat : pattern) = let rec resolve_path (path : Path.t) = match Env.find_type path pat.pat_env with - | {type_kind = Type_variant cstrs} -> + | {type_kind = Type_variant (cstrs, _)} -> Ast_untagged_variants.layout_from_type_variant ~env:pat.pat_env cstrs | {type_kind = Type_abstract; type_manifest = Some t} -> ( match (Ctype.unalias t).desc with diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 3b9d8c88685..17986c223eb 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -953,7 +953,7 @@ let pats_of_type ?(always = false) env ty = | Tconstr (path, _, _) -> ( try match (Env.find_type path env).type_kind with - | Type_variant cl + | Type_variant (cl, _) when always || List.length cl = 1 || List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index 146912d37c9..b6ca6f8d67b 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -221,17 +221,27 @@ and ident_some = ident_create "Some" and ident_ctor_unknown = ident_create "Unknown" +(* Predefined declarations are built by hand, so their layouts are too *) +let plain_variant (cstrs : Types.constructor_declaration list) = + Type_variant + ( cstrs, + Variant_runtime.plain_layout + (List.map + (fun (c : Types.constructor_declaration) -> + (Ident.name c.cd_id, c.cd_args <> Cstr_tuple [])) + cstrs) ) + let common_initial_env add_type add_extension empty_env = let decl_bool = { decl_abstr with - type_kind = Type_variant [cstr ident_false []; cstr ident_true []]; + type_kind = plain_variant [cstr ident_false []; cstr ident_true []]; type_immediate = true; } and decl_unit = { decl_abstr with - type_kind = Type_variant [cstr ident_void []]; + type_kind = plain_variant [cstr ident_void []]; type_immediate = true; } and decl_exn = {decl_abstr with type_kind = Type_open} @@ -266,7 +276,8 @@ let common_initial_env add_type add_extension empty_env = type_params = [tvar]; type_arity = 1; type_kind = - Type_variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]; + plain_variant + [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]; type_variance = [Variance.covariant]; } and decl_option = @@ -275,7 +286,7 @@ let common_initial_env add_type add_extension empty_env = decl_abstr with type_params = [tvar]; type_arity = 1; - type_kind = Type_variant [cstr ident_none []; cstr ident_some [tvar]]; + type_kind = plain_variant [cstr ident_none []; cstr ident_some [tvar]]; type_variance = [Variance.covariant]; } and decl_result = @@ -284,7 +295,8 @@ let common_initial_env add_type add_extension empty_env = decl_abstr with type_params = [tvar1; tvar2]; type_arity = 2; - type_kind = Type_variant [cstr ident_ok [tvar1]; cstr ident_error [tvar2]]; + type_kind = + plain_variant [cstr ident_ok [tvar1]; cstr ident_error [tvar2]]; type_variance = [Variance.covariant; Variance.covariant]; } and decl_dict = @@ -328,7 +340,7 @@ let common_initial_env add_type add_extension empty_env = type_params = []; type_arity = 0; type_kind = - Type_variant + plain_variant [ { cd_id = ident_ctor_unknown; diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index c866693e8b5..9c28d547e3a 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -826,7 +826,7 @@ and tree_of_type_decl id decl = in (match decl.type_kind with | Type_abstract -> () - | Type_variant cstrs -> + | Type_variant (cstrs, _) -> List.iter (fun c -> mark_loops_constructor_arguments c.cd_args; @@ -845,7 +845,7 @@ and tree_of_type_decl id decl = | Type_abstract -> decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private - | Type_variant tll -> + | Type_variant (tll, _) -> decl.type_private = Private || List.exists (fun cd -> cd.cd_res <> None) tll | Type_open -> decl.type_manifest = None @@ -878,7 +878,7 @@ and tree_of_type_decl id decl = | None -> (Otyp_abstract, Public) | Some ty -> (tree_of_typexp ~printing_context false ty, decl.type_private) ) - | Type_variant cstrs -> + | Type_variant (cstrs, _) -> untagged := Ast_untagged_variants.process_untagged decl.type_attributes; ( tree_of_manifest (Otyp_sum (List.map (tree_of_constructor ~printing_context) cstrs)), diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml index b8deaf22fee..46ebe3c720a 100644 --- a/compiler/ml/subst.ml +++ b/compiler/ml/subst.ml @@ -278,8 +278,8 @@ let type_declaration s decl = type_kind = (match decl.type_kind with | Type_abstract -> Type_abstract - | Type_variant cstrs -> - Type_variant (List.map (constructor_declaration s) cstrs) + | Type_variant (cstrs, layout) -> + Type_variant (List.map (constructor_declaration s) cstrs, layout) | Type_record (lbls, rep) -> Type_record (List.map (label_declaration s) lbls, rep) | Type_open -> Type_open); diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 38697eeb5ed..103347660d9 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -40,7 +40,7 @@ let num_nonconst_constructors env (cstr : Types.constructor_description) = match cstr.cstr_identity with | Ordinary_constructor {type_path} -> ( match (Env.find_type type_path env).type_kind with - | Type_variant cstrs -> + | Type_variant (cstrs, _) -> List.length (List.filter (fun (cd : Types.constructor_declaration) -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 14182f2630b..569db656d40 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -322,7 +322,7 @@ let is_private_record_field env label = let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with - | p0, p, {type_kind = Type_variant cstrs} -> (p0, p, cstrs) + | p0, p, {type_kind = Type_variant (cstrs, _)} -> (p0, p, cstrs) | p0, p, {type_kind = Type_open} -> (p0, p, []) | _ -> raise Not_found @@ -627,7 +627,7 @@ let build_or_pat env loc lid = let extract_type_from_pat_variant_spread env lid expected_ty = let path, decl = Typetexp.find_type env lid.loc lid.txt in match decl with - | {type_kind = Type_variant constructors; type_params} -> + | {type_kind = Type_variant (constructors, _); type_params} -> if List.length type_params > 0 then raise (Error (lid.loc, env, Type_params_not_supported lid.txt)); let ty = newgenty (Tconstr (path, [], ref Mnil)) in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 13cb11d95ba..7dd39523f2a 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -22,6 +22,11 @@ open Primitive open Types open Typetexp +let () = + Ast_untagged_variants.extract_concrete_typedecl := + Ctype.extract_concrete_typedecl +let () = Ast_untagged_variants.expand_head := Ctype.expand_head + type error = | Repeated_parameter | Duplicate_constructor of string @@ -138,8 +143,8 @@ let rec get_unboxed_type_representation env ty fuel = type_params; type_kind = ( Type_record ([{ld_type = ty2; _}], _) - | Type_variant [{cd_args = Cstr_tuple [ty2]; _}] - | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}] ); + | Type_variant ([{cd_args = Cstr_tuple [ty2]; _}], _) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], _) ); } -> get_unboxed_type_representation env (Ctype.apply env type_params ty2 args) @@ -366,7 +371,7 @@ let is_not_undefined_attr (attr : attribute) = any type variable present in [ty]. *) -let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = +let transl_declaration ~type_record_as_object env sdecl id = (* Check for @notUndefined attribute *) let has_not_undefined = List.exists is_not_undefined_attr sdecl.ptype_attributes @@ -490,7 +495,7 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = (match args with | Cstr_tuple [spread_variant] -> ( match Ctype.extract_concrete_typedecl env spread_variant with - | _, _, {type_kind = Type_variant constructors} -> + | _, _, {type_kind = Type_variant (constructors, _)} -> constructors |> List.iter (fun (c : Types.constructor_declaration) -> Hashtbl.add constructors_from_variant_spreads c.cd_id.name @@ -591,15 +596,11 @@ let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = make_cstr scstr) in let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in - let is_untagged_def = - Ast_untagged_variants.has_untagged sdecl.ptype_attributes - in - let well_formedness_check : Ast_untagged_variants.well_formedness_check = - {is_untagged_def; cstrs} - in - (* delay the check until the newenv is created to handle recursive types *) - untagged_wfc := well_formedness_check :: !untagged_wfc; - (Ttype_variant tcstrs, Type_variant cstrs, sdecl) + (* the canonical layout is computed once the whole recursive group is + in the environment *) + ( Ttype_variant tcstrs, + Type_variant (cstrs, Variant_runtime.dummy_layout), + sdecl ) | Ptype_record lbls_ -> ( let optional_labels = Ext_list.filter_map lbls_ (fun lbl -> @@ -796,7 +797,7 @@ let check_constraints ~type_record_as_object env sdecl (_, decl) = let visited = ref Type_set.empty in (match decl.type_kind with | Type_abstract -> () - | Type_variant l -> + | Type_variant (l, _) -> let find_pl = function | Ptype_variant pl -> pl | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false @@ -1288,7 +1289,7 @@ let compute_variance_decl env check decl ((required, _) as rloc) = in match decl.type_kind with | Type_abstract | Type_open -> compute_variance_type env check rloc decl mn - | Type_variant tll -> ( + | Type_variant (tll, _) -> ( if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env check rloc decl (mn @@ -1320,14 +1321,14 @@ let marked_as_immediate decl = Builtin_attributes.immediate decl.type_attributes let compute_immediacy env tdecl = match (tdecl.type_kind, tdecl.type_manifest) with - | Type_variant [{cd_args = Cstr_tuple [arg]; _}], _ - | Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _ + | Type_variant ([{cd_args = Cstr_tuple [arg]; _}], _), _ + | Type_variant ([{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _), _ | Type_record ([{ld_type = arg; _}], _), _ when tdecl.type_representation = Transparent -> ( match get_unboxed_type_representation env arg with | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) | None -> false) - | Type_variant (_ :: _ as cstrs), _ -> + | Type_variant ((_ :: _ as cstrs), _), _ -> not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) | Type_abstract, Some typ -> not (Ctype.maybe_pointer_type env typ) | Type_abstract, None -> marked_as_immediate tdecl @@ -1502,12 +1503,10 @@ let transl_type_decl env rec_flag sdecl_list = | Asttypes.Recursive | Asttypes.Nonrecursive -> (id, None) in let type_record_as_object = ref false in - let untagged_wfc = ref [] in let transl_declaration name_sdecl (id, slot) = current_slot := slot; Builtin_attributes.warning_scope name_sdecl.ptype_attributes (fun () -> - transl_declaration ~type_record_as_object ~untagged_wfc temp_env - name_sdecl id) + transl_declaration ~type_record_as_object temp_env name_sdecl id) in let tdecls = List.map2 transl_declaration sdecl_list (List.map id_slots id_list) @@ -1582,10 +1581,29 @@ let transl_type_decl env rec_flag sdecl_list = | Some ty -> raise (Error (sdecl.ptype_loc, Unbound_type_var (ty, decl))) | None -> ()) sdecl_list tdecls; - (* Check that constraints are enforced *) - List.iter - (fun check -> Ast_untagged_variants.check_well_formed ~env:newenv check) - !untagged_wfc; + (* Compute canonical runtime layouts. This also validates the untagged + invariants, which need the whole recursive group in the environment. *) + let decls = + List.map + (fun (id, decl) -> + match decl.type_kind with + | Type_variant (cstrs, _) -> + Ast_untagged_variants.check_tag_field_conflicts cstrs; + let is_untagged_def = + Ast_untagged_variants.has_untagged decl.type_attributes + in + let layout = + match + Ast_untagged_variants.layout_from_type_variant ~is_untagged_def + ~env:newenv cstrs + with + | Some layout -> layout + | None -> assert false + in + (id, {decl with type_kind = Type_variant (cstrs, layout)}) + | Type_abstract | Type_record _ | Type_open -> (id, decl)) + decls + in List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; (* Name recursion *) let decls = @@ -2169,7 +2187,7 @@ let report_error ppf = function fprintf ppf "A type variable is unbound in this type declaration"; let ty = Ctype.repr ty in match (decl.type_kind, decl.type_manifest) with - | Type_variant tl, _ -> + | Type_variant (tl, _), _ -> explain_unbound_gen ppf ty tl (fun c -> let tl = tys_of_constr_args c.Types.cd_args in diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index d4672623a18..558a656cc5b 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -56,17 +56,18 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = | Type_open -> false | Type_record _ -> true | Type_variant - ( [ - {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; - {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; - ] - | [ - {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; - {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; - ] - | [{cd_id = {name = "()"}; cd_args = Cstr_tuple []}] ) -> + ( ( [ + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; + ] + | [ + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; + ] + | [{cd_id = {name = "()"}; cd_args = Cstr_tuple []}] ), + _ ) -> false (* conservative *) - | Type_variant cdecls -> + | Type_variant (cdecls, _) -> let untagged = Ast_untagged_variants.has_untagged decl.type_attributes in diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index d1a2805beea..4affb2e701e 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -143,7 +143,8 @@ and type_inlined_type = and type_kind = | Type_abstract | Type_record of label_declaration list * record_representation - | Type_variant of constructor_declaration list + | Type_variant of + constructor_declaration list * Variant_runtime.variant_layout | Type_open and record_representation = diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 8afc111b1a9..9d6c4786ad9 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -249,7 +249,8 @@ and type_inlined_type = and type_kind = | Type_abstract | Type_record of label_declaration list * record_representation - | Type_variant of constructor_declaration list + | Type_variant of + constructor_declaration list * Variant_runtime.variant_layout | Type_open and record_representation = diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index b3599dce11f..d798d289753 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -137,7 +137,11 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with - | {type_kind = Type_variant constructors; type_params = []; type_attributes} + | { + type_kind = Type_variant (constructors, _); + type_params = []; + type_attributes; + } when not (Path.same p Predef.path_bool) -> (* bool is represented as a variant internally, so we need to account for that *) (* TODO(subtype-errors) Report about bool? *) diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml new file mode 100644 index 00000000000..d2fe37efd60 --- /dev/null +++ b/compiler/ml/variant_runtime.ml @@ -0,0 +1,139 @@ +(* The runtime representation of variants: plain data describing how each + constructor is laid out in JavaScript and how a whole variant is + dispatched on. This module sits below [Types] so the canonical layout can + be stored on type declarations; [Ast_untagged_variants] re-exports these + definitions and derives them from declarations. *) + +module Instance = struct + type t = + | Array + | ArrayBuffer + | BigInt64Array + | BigUint64Array + | Blob + | DataView + | Date + | File + | Float32Array + | Float64Array + | Int16Array + | Int32Array + | Int8Array + | Promise + | RegExp + | Uint16Array + | Uint32Array + | Uint8Array + | Uint8ClampedArray + | Set + | Map + | WeakSet + | WeakMap + let to_string = function + | Array -> "Array" + | ArrayBuffer -> "ArrayBuffer" + | BigInt64Array -> "BigInt64Array" + | BigUint64Array -> "BigUint64Array" + | Blob -> "Blob" + | DataView -> "DataView" + | Date -> "Date" + | File -> "File" + | Float32Array -> "Float32Array" + | Float64Array -> "Float64Array" + | Int16Array -> "Int16Array" + | Int32Array -> "Int32Array" + | Int8Array -> "Int8Array" + | Promise -> "Promise" + | RegExp -> "RegExp" + | Uint16Array -> "Uint16Array" + | Uint32Array -> "Uint32Array" + | Uint8Array -> "Uint8Array" + | Uint8ClampedArray -> "Uint8ClampedArray" + | Set -> "Set" + | Map -> "Map" + | WeakSet -> "WeakSet" + | WeakMap -> "WeakMap" +end + +(* Type of the runtime representation of an untagged block (case with payload) *) +type block_type = + | IntType + | StringType + | FloatType + | BigintType + | BooleanType + | InstanceType of Instance.t + | FunctionType + | ObjectType + | UnknownType + +(* + Type of the runtime representation of a tag. + Can be a literal (case with no payload), or a block (case with payload). + In the case of block it can be tagged or untagged. +*) +type tag_type = + | String of string + | Int of int + | Float of string + | BigInt of string + | Bool of bool + | Null + | Undefined (* literal or tagged block *) + | Untagged of block_type (* untagged block *) +type tag = {name: string; tag_type: tag_type option} + +type block_runtime = {tag: tag; tag_name: string option; untagged: bool} +(** Runtime information shared by construction and pattern matching for a + constructor carrying a payload. [block_type] is deliberately not part of + this value: it describes how a matcher recognizes an unboxed payload, not + how the value itself is constructed. *) + +type block = {runtime: block_runtime; block_type: block_type option} + +type constructor_case = Constant of tag | Block of block + +type variant_layout = { + constructors: constructor_case array; + constructors_by_name: (int * constructor_case) Map_string.t; +} +(** Canonical runtime layout in source-constructor order. *) + +type variant_dispatch = { + tag_name: string option; + block_types: block_type list; + literal_tags: tag_type list; + has_null: bool; + has_undefined: bool; + has_other_literal: bool; +} +(** The whole-variant information needed to choose a JavaScript dispatch + strategy. Constructor identity is carried by each switch arm instead. *) + +(* Placeholder used while a recursive declaration group is being typed; + [Typedecl] replaces it with the computed layout once the group is in the + environment *) +let dummy_layout = + {constructors = [||]; constructors_by_name = Map_string.empty} + +(* Layout of a variant that carries no representation attributes; used for + predefined types, whose declarations are built by hand *) +let plain_layout (cases : (string * bool (* has payload *)) list) = + let case (name, has_payload) = + if has_payload then + Block + { + runtime = + {tag = {name; tag_type = None}; tag_name = None; untagged = false}; + block_type = None; + } + else Constant {name; tag_type = None} + in + let constructors = Array.of_list (List.map case cases) in + let _, constructors_by_name = + List.fold_left + (fun (index, by_name) (name, _) -> + (index + 1, Map_string.add by_name name (index, constructors.(index)))) + (0, Map_string.empty) cases + in + {constructors; constructors_by_name} diff --git a/compiler/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml index 029d98c5f94..a3ba0f00864 100644 --- a/compiler/ml/variant_type_spread.ml +++ b/compiler/ml/variant_type_spread.ml @@ -42,9 +42,9 @@ let map_constructors ~(sdecl : Parsetree.type_declaration) ~all_constructors env in match type_decl with - | {type_kind = Type_variant []} -> + | {type_kind = Type_variant ([], _)} -> raise (VariantTypeSpreadError (loc.loc, InvalidType)) - | {type_kind = Type_variant cstrs; type_attributes; type_params} -> + | {type_kind = Type_variant (cstrs, _); type_attributes; type_params} -> if List.length type_params > 0 then raise (VariantTypeSpreadError (loc.loc, HasTypeParams)); @@ -145,7 +145,7 @@ let expand_dummy_constructor_args (sdecl_list : Parsetree.type_declaration list) (fun sdecl (_, decl) -> match (sdecl, decl) with | ( {Parsetree.ptype_kind = Ptype_variant c1}, - {Types.type_kind = Type_variant c2} ) -> + {Types.type_kind = Type_variant (c2, _)} ) -> { sdecl with ptype_kind = From 6ffd2bbd55a462b363ede357079472cb9c9068c3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 21 Aug 2026 16:43:36 +0200 Subject: [PATCH 3/7] Consume the stored variant layout everywhere Constructor descriptions now carry their declaring variant's layout, minted in datarepr from the declaration, and every consumer reads it instead of re-deriving representation facts: - Matching takes the layout straight from the constructor description; the per-switch type resolution and the sw_layout plumbing are gone, and sw_dispatch is the layout's precomputed dispatch. - Translcore counts payload constructors from the stored layout instead of looking the declaration up in the environment. - Parmatch reads a constructor's untagged block type from the stored layout instead of re-resolving the declaration. With typedecl the only remaining layout computer, the derivation (get_block_type and friends) moves to a new Variant_layout module above Ctype, and the Obj.magic forward references in Ast_untagged_variants are deleted: typing a declaration now determines its representation once, and it is never revisited. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01YWw5GW8t4UDEWAzoqcDMkE --- compiler/ml/ast_untagged_variants.ml | 155 +-------------------------- compiler/ml/datarepr.ml | 7 ++ compiler/ml/matching.ml | 29 +---- compiler/ml/parmatch.ml | 15 +-- compiler/ml/translcore.ml | 24 ++--- compiler/ml/typedecl.ml | 13 +-- compiler/ml/types.ml | 3 + compiler/ml/types.mli | 3 + compiler/ml/variant_layout.ml | 107 ++++++++++++++++++ compiler/ml/variant_runtime.ml | 63 +++++++++-- 10 files changed, 198 insertions(+), 221 deletions(-) create mode 100644 compiler/ml/variant_layout.ml diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index e36f110119c..cf81d1e5516 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -118,6 +118,7 @@ type constructor_case = Variant_runtime.constructor_case = type variant_layout = Variant_runtime.variant_layout = { constructors: constructor_case array; constructors_by_name: (int * constructor_case) Map_string.t; + dispatch: Variant_runtime.variant_dispatch; } (** Canonical runtime layout in source-constructor order. *) @@ -132,42 +133,6 @@ type variant_dispatch = Variant_runtime.variant_dispatch = { (** The whole-variant information needed to choose a JavaScript dispatch strategy. Constructor identity is carried by each switch arm instead. *) -let dispatch_from_layout layout = - let tag_name = ref None in - let block_types = ref [] in - let literal_tags = ref [] in - let has_null = ref false in - let has_undefined = ref false in - let has_other_literal = ref false in - Array.iter - (function - | Constant {name; tag_type} -> ( - let tag = - match tag_type with - | Some tag -> tag - | None -> String name - in - literal_tags := tag :: !literal_tags; - match tag with - | Null -> has_null := true - | Undefined -> has_undefined := true - | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ -> - has_other_literal := true) - | Block {runtime = {tag_name = constructor_tag_name}; block_type} -> ( - if !tag_name = None then tag_name := constructor_tag_name; - match block_type with - | Some block_type -> block_types := block_type :: !block_types - | None -> ())) - layout.constructors; - { - tag_name = !tag_name; - block_types = !block_types; - literal_tags = !literal_tags; - has_null = !has_null; - has_undefined = !has_undefined; - has_other_literal = !has_other_literal; - } - let constructor_by_name layout name = snd (Map_string.find_exn layout.constructors_by_name name) @@ -210,16 +175,6 @@ let process_untagged (attrs : Parsetree.attributes) = | _ -> ()); !st -(* Filled in by [Typedecl] to break the module cycle through [Ctype]; - installed at module initialization of the typing layer, so they are set - before any declaration is typed. *) -let extract_concrete_typedecl : - (Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration) ref = - ref (Obj.magic ()) - -let expand_head : (Env.t -> Types.type_expr -> Types.type_expr) ref = - ref (Obj.magic ()) - let process_tag_type (attrs : Parsetree.attributes) = let st : tag_type option ref = ref None in Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> @@ -301,57 +256,6 @@ let type_to_instanceof_backed_obj (t : Types.type_expr) = | _ -> None) | _ -> None -let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = - (* First check the original (unexpanded) type for typed arrays and other instance types *) - match type_to_instanceof_backed_obj t with - | Some instance_type -> Some (InstanceType instance_type) - | None -> ( - (* If original type didn't match, expand and try standard checks *) - let expanded_t = !expand_head env t in - match expanded_t with - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> - Some StringType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int -> - Some IntType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float -> - Some FloatType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint -> - Some BigintType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> - Some BooleanType - | {desc = Tarrow _} -> Some FunctionType - | {desc = Tconstr _} as expanded_t when type_is_builtin_object expanded_t -> - Some ObjectType - | {desc = Tconstr _} as expanded_t - when type_to_instanceof_backed_obj expanded_t |> Option.is_some -> ( - match type_to_instanceof_backed_obj expanded_t with - | None -> None - | Some instance_type -> Some (InstanceType instance_type)) - | {desc = Ttuple _} -> Some (InstanceType Array) - | _ -> None) - -let get_block_type ~env (cstr : Types.constructor_declaration) : - block_type option = - match (process_untagged cstr.cd_attributes, cstr.cd_args) with - | false, _ -> None - | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some - -> - get_block_type_from_typ ~env t - | true, Cstr_tuple [ty] -> ( - let default = Some UnknownType in - match !extract_concrete_typedecl env ty with - | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default - | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType - | _ -> default - | exception _ -> default) - | true, Cstr_tuple (_ :: _ :: _) -> - (* C(_, _) with at least 2 args is an object *) - Some ObjectType - | true, Cstr_record _ -> - (* inline record is an object *) - Some ObjectType - | true, _ -> None (* TODO: add restrictions here *) - let process_tag_name (attrs : Parsetree.attributes) = let st = ref None in Ext_list.iter attrs (fun ({txt; loc}, payload) -> @@ -485,61 +389,6 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) let get_cstr_loc_tag (cstr : Types.constructor_declaration) = (cstr.cd_loc, constructor_tag ~name:(Ident.name cstr.cd_id) cstr.cd_attributes) -let constructor_declaration_from_constructor_description ~env - (cd : Types.constructor_description) : Types.constructor_declaration option - = - match cd.cstr_res.desc with - | Tconstr (path, _, _) -> ( - match Env.find_type path env with - | {type_kind = Type_variant (cstrs, _)} -> - Ext_list.find_opt cstrs (fun cstr -> - if cstr.cd_id.name = cd.cstr_name then Some cstr else None) - | _ -> None) - | _ -> None - -let layout_from_type_variant ?(is_untagged_def = false) ~env - (cstrs : Types.constructor_declaration list) = - let get_block (cstr : Types.constructor_declaration) : block = - { - runtime = block_runtime ~name:(Ident.name cstr.cd_id) cstr.cd_attributes; - block_type = get_block_type ~env cstr; - } - in - let located_constructors = - List.map - (fun (cstr : Types.constructor_declaration) -> - if is_nullary_variant cstr.cd_args then - let loc, tag = get_cstr_loc_tag cstr in - (loc, Constant tag) - else (cstr.cd_loc, Block (get_block cstr))) - cstrs - in - let consts, blocks = - Ext_list.fold_left located_constructors ([], []) - (fun (consts, blocks) (loc, constructor) -> - match constructor with - | Constant tag -> ((loc, tag) :: consts, blocks) - | Block block -> (consts, (loc, block) :: blocks)) - in - check_invariant ~is_untagged_def ~consts ~blocks; - let constructors = - Array.of_list - (List.map (fun (_, constructor) -> constructor) located_constructors) - in - let constructors_by_name = - let _, constructors_by_name = - List.fold_left2 - (fun (index, constructors_by_name) - (cstr : Types.constructor_declaration) (_, constructor) -> - ( index + 1, - Map_string.add constructors_by_name (Ident.name cstr.cd_id) - (index, constructor) )) - (0, Map_string.empty) cstrs located_constructors - in - constructors_by_name - in - Some {constructors; constructors_by_name} - let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = List.iter (fun (cstr : Types.constructor_declaration) -> @@ -573,8 +422,6 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = let has_undefined_literal attrs = process_tag_type attrs = Some Undefined -let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType - module Dynamic_checks = struct type op = EqEqEq | NotEqEq | Or | And type 'a t = diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 72ca2017940..21351dd2c49 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -101,6 +101,11 @@ let constructor_has_optional_shape List.exists (fun (x, _) -> x.txt = internal_optional) attrs let constructor_descrs ty_path decl cstrs = + let layout = + match decl.type_kind with + | Type_variant (_, layout) -> layout + | Type_abstract | Type_record _ | Type_open -> assert false + in let ty_res = newgenconstr ty_path decl.type_params in let num_consts = ref 0 and num_nonconsts = ref 0 in List.iter @@ -141,6 +146,7 @@ let constructor_descrs ty_path decl cstrs = cstr_arity = List.length cstr_args; cstr_identity = Ordinary_constructor {type_path = ty_path; name = cstr_name}; + cstr_layout = Some layout; cstr_transparent = !num_consts = 0 && !num_nonconsts = 1 && cstr_args <> [] && List.exists @@ -196,6 +202,7 @@ let extension_descr path_ext ext = cstr_args; cstr_arity = List.length cstr_args; cstr_identity = Extension_constructor path_ext; + cstr_layout = None; cstr_transparent = false; cstr_private = ext.ext_private; cstr_generalized = ext.ext_ret_type <> None; diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 8916048d707..79a2a605a17 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2050,7 +2050,7 @@ let constructor_switch_key layout (cstr : Types.constructor_description) = Switch_constructor (Ast_untagged_variants.constructor_by_name layout cstr.cstr_name) -let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def +let combine_constructor loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = let is_extension = match cstr.cstr_identity with @@ -2088,7 +2088,7 @@ let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def else (* Regular concrete type *) let layout = - match sw_layout with + match cstr.cstr_layout with | Some layout -> layout | None -> assert false in @@ -2165,9 +2165,7 @@ let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def sw_blocks_full = List.length nonconsts >= num_nonconsts; sw_blocks = nonconsts; sw_failaction = fail_opt; - sw_dispatch = - Switch_variant - (Ast_untagged_variants.dispatch_from_layout layout); + sw_dispatch = Switch_variant layout.dispatch; } in let hs, sw = share_actions_sw sw in @@ -2457,24 +2455,6 @@ let arg_to_var arg cls = let v = name_pattern "match" cls in (v, Lvar v) -(* Resolve the canonical variant layout of a constructor pattern's type, - following manifest chains to the declaration *) -let layout_from_construct_pattern (pat : pattern) = - let rec resolve_path (path : Path.t) = - match Env.find_type path pat.pat_env with - | {type_kind = Type_variant (cstrs, _)} -> - Ast_untagged_variants.layout_from_type_variant ~env:pat.pat_env cstrs - | {type_kind = Type_abstract; type_manifest = Some t} -> ( - match (Ctype.unalias t).desc with - | Tconstr (pathn, _, _) -> resolve_path pathn - | _ -> None) - | {type_kind = Type_abstract; type_manifest = None} -> None - | {type_kind = Type_record _ | Type_open (* Exceptions *)} -> None - in - match (Btype.repr pat.pat_type).desc with - | Tconstr (path, _, _) -> resolve_path path - | _ -> assert false - (* The main compilation function. Input: @@ -2545,11 +2525,10 @@ and do_compile_matching repr partial ctx arg pmh = (combine_constant pat.pat_loc arg cst partial) ctx pm | Tpat_construct (_, cstr, _) -> - let sw_layout = layout_from_construct_pattern pat in compile_test (compile_match repr partial) partial divide_constructor - (combine_constructor sw_layout pat.pat_loc arg pat cstr partial) + (combine_constructor pat.pat_loc arg pat cstr partial) ctx pm | Tpat_array _ -> compile_test diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 17986c223eb..1d901755a7f 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -560,23 +560,18 @@ let all_record_args lbls = _, [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] ) when lbl_is_optional () -> ( - let cdecl = - Ast_untagged_variants - .constructor_declaration_from_constructor_description - ~env:pat.pat_env cd - in - match cdecl with + match cd.cstr_layout with | None -> x - | Some cstr -> ( + | Some layout -> ( match - Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr + Ast_untagged_variants.constructor_by_name layout cd.cstr_name with - | Some block_type + | Block {block_type = Some block_type} when not (Ast_untagged_variants.block_type_can_be_undefined block_type) -> (id, lbl, pat_construct, o) - | _ -> x)) + | Constant _ | Block _ -> x)) | _ -> x in t.(lbl.lbl_pos) <- x) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 103347660d9..c37127a0e8c 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -36,18 +36,16 @@ let transl_module = (* Number of payload-carrying constructors of the variant declaring [cstr]; part of the runtime representation of its blocks *) -let num_nonconst_constructors env (cstr : Types.constructor_description) = - match cstr.cstr_identity with - | Ordinary_constructor {type_path} -> ( - match (Env.find_type type_path env).type_kind with - | Type_variant (cstrs, _) -> - List.length - (List.filter - (fun (cd : Types.constructor_declaration) -> - cd.cd_args <> Cstr_tuple []) - cstrs) - | _ -> assert false) - | Extension_constructor _ -> assert false +let num_nonconst_constructors (cstr : Types.constructor_description) = + match cstr.cstr_layout with + | Some layout -> + Array.fold_left + (fun n (case : Variant_runtime.constructor_case) -> + match case with + | Block _ -> n + 1 + | Constant _ -> n) + 0 layout.constructors + | None -> assert false (* Compile an exception/extension definition *) @@ -812,7 +810,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Blk_constructor { name = cstr.cstr_name; - num_nonconst = num_nonconst_constructors e.exp_env cstr; + num_nonconst = num_nonconst_constructors cstr; runtime; } in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 7dd39523f2a..bbad6d94db9 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -22,11 +22,6 @@ open Primitive open Types open Typetexp -let () = - Ast_untagged_variants.extract_concrete_typedecl := - Ctype.extract_concrete_typedecl -let () = Ast_untagged_variants.expand_head := Ctype.expand_head - type error = | Repeated_parameter | Duplicate_constructor of string @@ -1593,12 +1588,8 @@ let transl_type_decl env rec_flag sdecl_list = Ast_untagged_variants.has_untagged decl.type_attributes in let layout = - match - Ast_untagged_variants.layout_from_type_variant ~is_untagged_def - ~env:newenv cstrs - with - | Some layout -> layout - | None -> assert false + Variant_layout.layout_from_type_variant ~is_untagged_def ~env:newenv + cstrs in (id, {decl with type_kind = Type_variant (cstrs, layout)}) | Type_abstract | Type_record _ | Type_open -> (id, decl)) diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index 4affb2e701e..e8c813ab9c8 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -251,6 +251,9 @@ type constructor_description = { cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_identity: constructor_identity; (* Semantic identity *) + cstr_layout: Variant_runtime.variant_layout option; + (* Runtime layout of the declaring variant; None for extension + constructors *) cstr_transparent: bool; (* Sole payload-carrying constructor of an unboxed type: constructing it is the identity at runtime *) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 9d6c4786ad9..6a730645782 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -355,6 +355,9 @@ type constructor_description = { cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_identity: constructor_identity; (* Semantic identity *) + cstr_layout: Variant_runtime.variant_layout option; + (* Runtime layout of the declaring variant; None for extension + constructors *) cstr_transparent: bool; (* Sole payload-carrying constructor of an unboxed type: constructing it is the identity at runtime *) diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml new file mode 100644 index 00000000000..bdb5c8cdf71 --- /dev/null +++ b/compiler/ml/variant_layout.ml @@ -0,0 +1,107 @@ +(* Derivation of the canonical runtime layout of a variant declaration. + + This runs exactly once per declaration, in [Typedecl], after the whole + recursive group has entered the environment; the result is stored on + [Type_variant] and never re-derived. It lives above [Ctype] because + classifying untagged payloads requires expanding their types. *) + +open Ast_untagged_variants + +let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = + (* First check the original (unexpanded) type for typed arrays and other instance types *) + match type_to_instanceof_backed_obj t with + | Some instance_type -> Some (InstanceType instance_type) + | None -> ( + (* If original type didn't match, expand and try standard checks *) + let expanded_t = Ctype.expand_head env t in + match expanded_t with + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> + Some StringType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int -> + Some IntType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float -> + Some FloatType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint -> + Some BigintType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> + Some BooleanType + | {desc = Tarrow _} -> Some FunctionType + | {desc = Tconstr _} as expanded_t when type_is_builtin_object expanded_t -> + Some ObjectType + | {desc = Tconstr _} as expanded_t + when type_to_instanceof_backed_obj expanded_t |> Option.is_some -> ( + match type_to_instanceof_backed_obj expanded_t with + | None -> None + | Some instance_type -> Some (InstanceType instance_type)) + | {desc = Ttuple _} -> Some (InstanceType Array) + | _ -> None) + +let get_block_type ~env (cstr : Types.constructor_declaration) : + block_type option = + match (process_untagged cstr.cd_attributes, cstr.cd_args) with + | false, _ -> None + | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some + -> + get_block_type_from_typ ~env t + | true, Cstr_tuple [ty] -> ( + let default = Some UnknownType in + match Ctype.extract_concrete_typedecl env ty with + | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default + | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType + | _ -> default + | exception _ -> default) + | true, Cstr_tuple (_ :: _ :: _) -> + (* C(_, _) with at least 2 args is an object *) + Some ObjectType + | true, Cstr_record _ -> + (* inline record is an object *) + Some ObjectType + | true, _ -> None (* TODO: add restrictions here *) + +let layout_from_type_variant ?(is_untagged_def = false) ~env + (cstrs : Types.constructor_declaration list) : + Variant_runtime.variant_layout = + let get_block (cstr : Types.constructor_declaration) : block = + { + runtime = block_runtime ~name:(Ident.name cstr.cd_id) cstr.cd_attributes; + block_type = get_block_type ~env cstr; + } + in + let located_constructors = + List.map + (fun (cstr : Types.constructor_declaration) -> + if is_nullary_variant cstr.cd_args then + let loc, tag = get_cstr_loc_tag cstr in + (loc, Constant tag) + else (cstr.cd_loc, Block (get_block cstr))) + cstrs + in + let consts, blocks = + Ext_list.fold_left located_constructors ([], []) + (fun (consts, blocks) (loc, constructor) -> + match constructor with + | Constant tag -> ((loc, tag) :: consts, blocks) + | Block block -> (consts, (loc, block) :: blocks)) + in + check_invariant ~is_untagged_def ~consts ~blocks; + let constructors = + Array.of_list + (List.map (fun (_, constructor) -> constructor) located_constructors) + in + let constructors_by_name = + let _, constructors_by_name = + List.fold_left2 + (fun (index, constructors_by_name) + (cstr : Types.constructor_declaration) (_, constructor) -> + ( index + 1, + Map_string.add constructors_by_name (Ident.name cstr.cd_id) + (index, constructor) )) + (0, Map_string.empty) cstrs located_constructors + in + constructors_by_name + in + { + constructors; + constructors_by_name; + dispatch = Variant_runtime.dispatch_of_constructors constructors; + } diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index d2fe37efd60..a3b4f492cce 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -93,12 +93,6 @@ type block = {runtime: block_runtime; block_type: block_type option} type constructor_case = Constant of tag | Block of block -type variant_layout = { - constructors: constructor_case array; - constructors_by_name: (int * constructor_case) Map_string.t; -} -(** Canonical runtime layout in source-constructor order. *) - type variant_dispatch = { tag_name: string option; block_types: block_type list; @@ -110,11 +104,60 @@ type variant_dispatch = { (** The whole-variant information needed to choose a JavaScript dispatch strategy. Constructor identity is carried by each switch arm instead. *) +type variant_layout = { + constructors: constructor_case array; + constructors_by_name: (int * constructor_case) Map_string.t; + dispatch: variant_dispatch; +} +(** Canonical runtime layout in source-constructor order, with the + precomputed dispatch strategy. *) + +let dispatch_of_constructors (constructors : constructor_case array) : + variant_dispatch = + let tag_name = ref None in + let block_types = ref [] in + let literal_tags = ref [] in + let has_null = ref false in + let has_undefined = ref false in + let has_other_literal = ref false in + Array.iter + (function + | Constant {name; tag_type} -> ( + let tag = + match tag_type with + | Some tag -> tag + | None -> String name + in + literal_tags := tag :: !literal_tags; + match tag with + | Null -> has_null := true + | Undefined -> has_undefined := true + | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ -> + has_other_literal := true) + | Block {runtime = {tag_name = constructor_tag_name}; block_type} -> ( + if !tag_name = None then tag_name := constructor_tag_name; + match block_type with + | Some block_type -> block_types := block_type :: !block_types + | None -> ())) + constructors; + { + tag_name = !tag_name; + block_types = !block_types; + literal_tags = !literal_tags; + has_null = !has_null; + has_undefined = !has_undefined; + has_other_literal = !has_other_literal; + } + (* Placeholder used while a recursive declaration group is being typed; [Typedecl] replaces it with the computed layout once the group is in the environment *) let dummy_layout = - {constructors = [||]; constructors_by_name = Map_string.empty} + { + constructors = [||]; + constructors_by_name = Map_string.empty; + dispatch = dispatch_of_constructors [||]; + } (* Layout of a variant that carries no representation attributes; used for predefined types, whose declarations are built by hand *) @@ -136,4 +179,8 @@ let plain_layout (cases : (string * bool (* has payload *)) list) = (index + 1, Map_string.add by_name name (index, constructors.(index)))) (0, Map_string.empty) cases in - {constructors; constructors_by_name} + { + constructors; + constructors_by_name; + dispatch = dispatch_of_constructors constructors; + } From 58f88002f1fa4be27dd05016bc0bd9b9483c957b Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 21 Aug 2026 16:54:45 +0200 Subject: [PATCH 4/7] Collapse constructor identity into a kind MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The Ordinary_constructor payload duplicated information already on the description: its name field mirrored cstr_name (read only by same_constructor, which has the whole description in hand), and its type_path had no remaining reader once the stored layout replaced the declaration lookups. constructor_identity becomes constructor_kind — Ordinary_constructor | Extension_constructor of Path.t — and identity is the pair of cstr_kind and cstr_name, or the extension's path. This also removes the unenforced invariant that the identity's name matched cstr_name, and makes the wrong comparison (ordinary constructors by path, which re-exports would break) inexpressible. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01YWw5GW8t4UDEWAzoqcDMkE --- analysis/reanalyze/src/dead_value.ml | 4 ++-- compiler/ml/datarepr.ml | 5 ++--- compiler/ml/env.ml | 8 ++++---- compiler/ml/matching.ml | 20 ++++++++++---------- compiler/ml/parmatch.ml | 20 ++++++++------------ compiler/ml/rec_check.ml | 2 +- compiler/ml/translcore.ml | 14 +++++--------- compiler/ml/typecore.ml | 2 +- compiler/ml/typedecl.ml | 2 +- compiler/ml/types.ml | 25 ++++++++++++------------- compiler/ml/types.mli | 16 ++++++++-------- 11 files changed, 54 insertions(+), 64 deletions(-) diff --git a/analysis/reanalyze/src/dead_value.ml b/analysis/reanalyze/src/dead_value.ml index e6188790cab..35f775fee7e 100644 --- a/analysis/reanalyze/src/dead_value.ml +++ b/analysis/reanalyze/src/dead_value.ml @@ -230,10 +230,10 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees ( _, { cstr_loc = {Location.loc_start = pos_to; loc_ghost} as loc_to; - cstr_identity; + cstr_kind; }, _ ) -> - (match cstr_identity with + (match cstr_kind with | Extension_constructor path -> path |> Dead_exception.mark_as_used ~config ~refs ~file_deps ~cross_file diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 21351dd2c49..fa81e8d4e44 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -144,8 +144,7 @@ let constructor_descrs ty_path decl cstrs = cstr_existentials = existentials; cstr_args; cstr_arity = List.length cstr_args; - cstr_identity = - Ordinary_constructor {type_path = ty_path; name = cstr_name}; + cstr_kind = Ordinary_constructor; cstr_layout = Some layout; cstr_transparent = !num_consts = 0 && !num_nonconsts = 1 && cstr_args <> [] @@ -201,7 +200,7 @@ let extension_descr path_ext ext = cstr_existentials = existentials; cstr_args; cstr_arity = List.length cstr_args; - cstr_identity = Extension_constructor path_ext; + cstr_kind = Extension_constructor path_ext; cstr_layout = None; cstr_transparent = false; cstr_private = ext.ext_private; diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml index b28b4828ae9..565b2355e0d 100644 --- a/compiler/ml/env.ml +++ b/compiler/ml/env.ml @@ -510,7 +510,7 @@ let is_ident = function | Pdot _ | Papply _ -> false let is_local_ext = function - | {cstr_identity = Extension_constructor p} -> is_ident p + | {cstr_kind = Extension_constructor p} -> is_ident p | _ -> false let diff env1 env2 = @@ -851,7 +851,7 @@ let find_type_full path env = Ext_list.filter (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false) (function - | {cstr_identity = Extension_constructor _} -> true + | {cstr_kind = Extension_constructor _} -> true | _ -> false) in @@ -1092,7 +1092,7 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env = let has_local_constraints env = not (Path_map.is_empty env.local_constraints) let cstr_shadow cstr1 cstr2 = - match (cstr1.cstr_identity, cstr2.cstr_identity) with + match (cstr1.cstr_kind, cstr2.cstr_kind) with | Extension_constructor _, Extension_constructor _ -> true | _ -> false @@ -1211,7 +1211,7 @@ let lookup_all_constructors ?loc lid env = let mark_constructor usage env name desc = if not (is_implicit_coercion env) then - match desc.cstr_identity with + match desc.cstr_kind with | Extension_constructor _ -> ( let ty_path = ty_path desc.cstr_res in let ty_name = Path.last ty_path in diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 79a2a605a17..0e9a9bcd5d9 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -927,7 +927,7 @@ and split_constr cls args def k = let ex_pat = what_is_cases cls in match ex_pat.pat_desc with | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_, {cstr_identity = Extension_constructor _}, _) -> + | Tpat_construct (_, {cstr_kind = Extension_constructor _}, _) -> split_naive cls args def k | _ -> ( let group = get_group ex_pat in @@ -1271,8 +1271,8 @@ let make_constr_matching p def ctx = function if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then (arg, Alias) :: argl else - match cstr.cstr_identity with - | Ordinary_constructor _ + match cstr.cstr_kind with + | Ordinary_constructor when cstr.cstr_args <> [] && Datarepr.constructor_has_optional_shape cstr -> let from_option = @@ -1283,7 +1283,7 @@ let make_constr_matching p def ctx = function | _ -> Pval_from_option in (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl - | Ordinary_constructor _ -> + | Ordinary_constructor -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) | Extension_constructor _ -> @@ -2005,8 +2005,8 @@ let split_cases tag_lambda_list = | [] -> ([], []) | (cstr, act) :: rem -> ( let consts, nonconsts = split_rec rem in - match cstr.cstr_identity with - | Ordinary_constructor _ -> + match cstr.cstr_kind with + | Ordinary_constructor -> if cstr.cstr_args = [] then ((cstr, act) :: consts, nonconsts) else (consts, (cstr, act) :: nonconsts) | Extension_constructor _ -> assert false) @@ -2031,9 +2031,9 @@ let get_extension_cases tag_lambda_list = | [] -> [] | (cstr, act) :: rem -> ( let nonconsts = split_rec rem in - match cstr.cstr_identity with + match cstr.cstr_kind with | Extension_constructor path -> (path, act) :: nonconsts - | Ordinary_constructor _ -> assert false) + | Ordinary_constructor -> assert false) in split_rec tag_lambda_list @@ -2053,9 +2053,9 @@ let constructor_switch_key layout (cstr : Types.constructor_description) = let combine_constructor loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = let is_extension = - match cstr.cstr_identity with + match cstr.cstr_kind with | Extension_constructor _ -> true - | Ordinary_constructor _ -> false + | Ordinary_constructor -> false in if is_extension then (* Special cases for extensions *) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 1d901755a7f..6f2d1ccecd2 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -862,9 +862,9 @@ let row_of_pat pat = let full_match closing env = match env with | (({pat_desc = Tpat_construct (_, c, _)} as p), _) :: _ -> ( - match c.cstr_identity with + match c.cstr_kind with | Extension_constructor _ -> false - | Ordinary_constructor _ -> + | Ordinary_constructor -> List.length env = List.length (get_variant_constructors p.pat_env c.cstr_res)) | (({pat_desc = Tpat_variant _} as p), _) :: _ -> @@ -910,11 +910,10 @@ let should_extend ext env = | [] -> assert false | (p, _) :: _ -> ( match p.pat_desc with - | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, _) -> + | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, _) -> let path = get_type_path p.pat_type p.pat_env in Path.same path ext - | Tpat_construct (_, {cstr_identity = Extension_constructor _}, _) -> - false + | Tpat_construct (_, {cstr_kind = Extension_constructor _}, _) -> false | Tpat_constant _ | Tpat_tuple _ | Tpat_variant _ | Tpat_record _ | Tpat_array _ -> false @@ -987,7 +986,7 @@ let complete_constrs p seen_constrs = let build_other_constrs env p = match p.pat_desc with - | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, _) -> + | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, _) -> let get_constr = function | {pat_desc = Tpat_construct (_, c, _)} -> c | _ -> fatal_error "Parmatch.get_constr" @@ -1015,10 +1014,7 @@ let some_other_tag = "" let build_other ext env : Typedtree.pattern = match env with - | ( { - pat_desc = - Tpat_construct (lid, {cstr_identity = Extension_constructor _}, _); - }, + | ( {pat_desc = Tpat_construct (lid, {cstr_kind = Extension_constructor _}, _)}, _ ) :: _ -> (* let c = {c with cstr_name = "*extension*"} in *) @@ -2141,7 +2137,7 @@ let extendable_path path = let rec collect_paths_from_pat r p = match p.pat_desc with - | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, ps) -> + | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, ps) -> let path = get_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat (if extendable_path path then add_path path r else r) @@ -2149,7 +2145,7 @@ let rec collect_paths_from_pat r p = | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> r | Tpat_tuple ps | Tpat_array ps - | Tpat_construct (_, {cstr_identity = Extension_constructor _}, ps) -> + | Tpat_construct (_, {cstr_kind = Extension_constructor _}, ps) -> List.fold_left collect_paths_from_pat r ps | Tpat_record (lps, _, _rest) -> List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index d3f0dad2918..0bdc7516904 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -264,7 +264,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Texp_array exprs -> Use.guard (list expression env exprs) | Texp_construct (_, desc, exprs) -> let access_constructor = - match desc.cstr_identity with + match desc.cstr_kind with | Extension_constructor pth -> Use.inspect (path env pth) | _ -> Use.empty in diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index c37127a0e8c..77c658d4b34 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -537,18 +537,14 @@ let transl_primitive_application loc prim env ty args = { exp_desc = Texp_construct - ( _, - {cstr_identity = Ordinary_constructor _; cstr_args = []}, - _ ); + (_, {cstr_kind = Ordinary_constructor; cstr_args = []}, _); }; ] | [ { exp_desc = Texp_construct - ( _, - {cstr_identity = Ordinary_constructor _; cstr_args = []}, - _ ); + (_, {cstr_kind = Ordinary_constructor; cstr_args = []}, _); }; _; ] @@ -778,8 +774,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | [x] -> x | _ -> assert false else - match cstr.cstr_identity with - | Ordinary_constructor _ when cstr.cstr_args = [] -> + match cstr.cstr_kind with + | Ordinary_constructor when cstr.cstr_args = [] -> Lconst (Const_pointer (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none @@ -787,7 +783,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Pt_constructor (Ast_untagged_variants.constructor_tag ~name:cstr.cstr_name cstr.cstr_attributes))) - | Ordinary_constructor _ -> ( + | Ordinary_constructor -> ( let runtime = Ast_untagged_variants.block_runtime ~name:cstr.cstr_name cstr.cstr_attributes diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 569db656d40..5afedb5bb3c 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3450,7 +3450,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp }; ] -> let path = - match (Typetexp.find_constructor env lid.loc lid.txt).cstr_identity with + match (Typetexp.find_constructor env lid.loc lid.txt).cstr_kind with | Extension_constructor path -> path | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) in diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index bbad6d94db9..e7179c287f3 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1690,7 +1690,7 @@ let transl_extension_constructor env type_path type_params typext_params priv | Private, Public -> raise (Error (lid.loc, Rebind_private lid.txt)) | _ -> ()); let path = - match cdescr.cstr_identity with + match cdescr.cstr_kind with | Extension_constructor path -> path | _ -> assert false in diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index e8c813ab9c8..afbd287c82f 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -250,7 +250,7 @@ type constructor_description = { cstr_existentials: type_expr list; (* list of existentials *) cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) - cstr_identity: constructor_identity; (* Semantic identity *) + cstr_kind: constructor_kind; cstr_layout: Variant_runtime.variant_layout option; (* Runtime layout of the declaring variant; None for extension constructors *) @@ -264,13 +264,13 @@ type constructor_description = { cstr_inlined: type_declaration option; } -and constructor_identity = - | Ordinary_constructor of {type_path: Path.t; name: string} - (* Constructor introduced by a variant type declaration. The path is - the path of the declaring type as written, so a re-exported variant - (type u = M.t = A | B) yields descriptions carrying the - re-exporting type's path. *) - | Extension_constructor of Path.t (* Extension constructor *) +and constructor_kind = + | Ordinary_constructor + (* Constructor introduced by a variant type declaration; identified + within its variant by [cstr_name] *) + | Extension_constructor of Path.t +(* Extension constructor, identified by its own path since extension + constructors can be rebound *) (* Whether two constructor descriptions denote the same constructor of a common scrutinee type. Because a re-exported variant mints descriptions @@ -278,14 +278,13 @@ and constructor_identity = only; the shared scrutinee type makes the name unambiguous. Not a general-purpose identity test across unrelated types. *) let same_constructor c1 c2 = - match (c1.cstr_identity, c2.cstr_identity) with - | Ordinary_constructor {name = n1}, Ordinary_constructor {name = n2} -> - n1 = n2 + match (c1.cstr_kind, c2.cstr_kind) with + | Ordinary_constructor, Ordinary_constructor -> c1.cstr_name = c2.cstr_name | Extension_constructor p1, Extension_constructor p2 -> Path.same p1 p2 - | (Ordinary_constructor _ | Extension_constructor _), _ -> false + | (Ordinary_constructor | Extension_constructor _), _ -> false let may_equal_constr c1 c2 = - match (c1.cstr_identity, c2.cstr_identity) with + match (c1.cstr_kind, c2.cstr_kind) with | Extension_constructor _, Extension_constructor _ -> (* extension constructors may be rebound, so paths cannot disprove equality; arity can *) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 6a730645782..dfc62dd924c 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -354,7 +354,7 @@ type constructor_description = { cstr_existentials: type_expr list; (* list of existentials *) cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) - cstr_identity: constructor_identity; (* Semantic identity *) + cstr_kind: constructor_kind; cstr_layout: Variant_runtime.variant_layout option; (* Runtime layout of the declaring variant; None for extension constructors *) @@ -368,13 +368,13 @@ type constructor_description = { cstr_inlined: type_declaration option; } -and constructor_identity = - | Ordinary_constructor of {type_path: Path.t; name: string} - (* Constructor introduced by a variant type declaration. The path is - the path of the declaring type as written, so a re-exported variant - (type u = M.t = A | B) yields descriptions carrying the - re-exporting type's path. *) - | Extension_constructor of Path.t (* Extension constructor *) +and constructor_kind = + | Ordinary_constructor + (* Constructor introduced by a variant type declaration; identified + within its variant by [cstr_name] *) + | Extension_constructor of Path.t +(* Extension constructor, identified by its own path since extension + constructors can be rebound *) (* Constructor descriptions of a common scrutinee type denote the same constructor: ordinary constructors compare by name (re-exported variants From eba15a7ac3bf00ca53fd4a9143196a1d529b7f70 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 21 Aug 2026 17:09:12 +0200 Subject: [PATCH 5/7] Shrink the stored layout to its honest content Review of the representation changes found derived data stored beside its source and duplicate derivations: - variant_layout collapses to the constructors array. The by-name map duplicated every case (and the names inside them), and the dispatch field was derivable; both are now computed by accessors, with the dispatch derived at its single consumer in Matching. - cstr_transparent was derivable from cstr_layout plus the unboxed attribute once descriptions carried their layout; it is a Datarepr predicate again, now environment-free. - Construction in Translcore reads the constructor's layout entry (Datarepr.constructor_case) instead of re-deriving the tag and block runtime from attributes, closing the last spot where construction and matching could derive representation independently. - Parmatch's full_match compares against the layout's length instead of looking the declaration up in the environment; the block-count folds in Translcore, Matching, and Datarepr use one Variant_runtime helper; js_dump drops a tautological num_nonconst test. - The type-equation re-exports in Ast_untagged_variants are gone: consumers reference Variant_runtime directly. Co-Authored-By: Claude Fable 5 Claude-Session: https://claude.ai/code/session_01YWw5GW8t4UDEWAzoqcDMkE --- compiler/core/j.ml | 2 +- compiler/core/js_dump.ml | 8 ++-- compiler/core/js_exp_make.ml | 6 +-- compiler/core/js_exp_make.mli | 6 +-- compiler/core/js_of_lam_variant.ml | 6 +-- compiler/core/js_stmt_make.ml | 2 +- compiler/core/js_stmt_make.mli | 2 +- compiler/core/lam.ml | 2 +- compiler/core/lam_compile.ml | 22 ++++----- compiler/core/lam_constant_convert.ml | 2 +- compiler/frontend/lam_constant.ml | 2 +- compiler/frontend/lam_constant.mli | 2 +- compiler/ml/ast_untagged_variants.ml | 67 +-------------------------- compiler/ml/datarepr.ml | 34 +++++++------- compiler/ml/datarepr.mli | 3 ++ compiler/ml/lambda.ml | 13 +++--- compiler/ml/lambda.mli | 12 ++--- compiler/ml/matching.ml | 23 +++------ compiler/ml/parmatch.ml | 14 ++---- compiler/ml/rec_check.ml | 4 +- compiler/ml/translcore.ml | 20 ++++---- compiler/ml/types.ml | 3 -- compiler/ml/types.mli | 3 -- compiler/ml/variant_coercion.ml | 4 +- compiler/ml/variant_layout.ml | 19 +------- compiler/ml/variant_runtime.ml | 67 ++++++++++++++++----------- 26 files changed, 130 insertions(+), 218 deletions(-) diff --git a/compiler/core/j.ml b/compiler/core/j.ml index 0dc2e80dff8..13815ac478b 100644 --- a/compiler/core/j.ml +++ b/compiler/core/j.ml @@ -244,7 +244,7 @@ and case_clause = { source_loc: Location.t option; } -and string_clause = Ast_untagged_variants.tag_type * case_clause +and string_clause = Variant_runtime.tag_type * case_clause and int_clause = int * case_clause and label = string diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 4bef8c4a0f3..756b4334786 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -970,7 +970,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Caml_block (el, _, ((Blk_extension | Blk_record_ext _) as ext)) -> expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext) | Caml_block (el, _, Blk_record_inlined p) -> - let {Ast_untagged_variants.tag; tag_name; untagged} = p.runtime in + let {Variant_runtime.tag; tag_name; untagged} = p.runtime in let objs = let tails = Ext_list.combine_array p.fields el (fun (i, opt) -> (Js_op.Lit i, opt)) @@ -994,7 +994,7 @@ and expression_desc cxt ~(level : int) f x : cxt = expression_desc cxt ~level f (Object (None, objs)) | Caml_block (el, _, Blk_constructor p) -> let not_is_cons = p.name <> Literals.cons in - let {Ast_untagged_variants.tag; tag_name; untagged} = p.runtime in + let {Variant_runtime.tag; tag_name; untagged} = p.runtime in let tag_type = tag.tag_type in let tag_name = Option.value tag_name ~default:L.tag in let objs = @@ -1010,7 +1010,7 @@ and expression_desc cxt ~(level : int) f x : cxt = [(name_symbol, E.str p.name)] else []) in - if untagged || (not_is_cons = false && p.num_nonconst = 1) then tails + if untagged || not_is_cons = false then tails else ( Js_op.Lit tag_name, (* TAG:xx *) @@ -1689,7 +1689,7 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt = let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in P.space f; P.brace_vgroup f 1 (fun _ -> - let pp_as_value f (tag_type : Ast_untagged_variants.tag_type) = + let pp_as_value f (tag_type : Variant_runtime.tag_type) = let e = E.tag_type tag_type in ignore @@ expression_desc cxt ~level:0 f e.expression_desc in diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index c158660a72d..a40ec2b1f7e 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1358,7 +1358,7 @@ let rec float_equal ?comment (e0 : t) (e1 : t) : t = let int_equal = float_equal let tag_type = function - | Ast_untagged_variants.String s -> str s ~delim:DStarJ + | Variant_runtime.String s -> str s ~delim:DStarJ | Int i -> small_int i | Float f -> float f | BigInt i -> @@ -1374,7 +1374,7 @@ let tag_type = function | Untagged FunctionType -> str "function" | Untagged StringType -> str "string" | Untagged (InstanceType i) -> - str (Ast_untagged_variants.Instance.to_string i) ~delim:DNoQuotes + str (Variant_runtime.Instance.to_string i) ~delim:DNoQuotes | Untagged ObjectType -> str "object" | Untagged UnknownType -> (* TODO: this should not happen *) @@ -1395,7 +1395,7 @@ let rec emit_check (check : t Ast_untagged_variants.Dynamic_checks.t) = | TypeOf x -> typeof (emit_check x) | IsInstanceOf (Array, x) -> is_array (emit_check x) | IsInstanceOf (instance, x) -> - let instance_name = Ast_untagged_variants.Instance.to_string instance in + let instance_name = Variant_runtime.Instance.to_string instance in instanceof (emit_check x) (str instance_name ~delim:DNoQuotes) | Not x -> not (emit_check x) | Expr x -> x diff --git a/compiler/core/js_exp_make.mli b/compiler/core/js_exp_make.mli index e0ac104a7f0..2482beb219b 100644 --- a/compiler/core/js_exp_make.mli +++ b/compiler/core/js_exp_make.mli @@ -165,7 +165,7 @@ val extension_assign : t -> int32 -> string -> t -> t val assign : ?comment:string -> t -> t -> t -val tag_type : Ast_untagged_variants.tag_type -> t +val tag_type : Variant_runtime.tag_type -> t val emit_check : t Ast_untagged_variants.Dynamic_checks.t -> t @@ -187,8 +187,8 @@ val is_type_number : ?comment:string -> t -> t val is_int_tag : ?has_null_undefined_other:bool * bool * bool -> t -> t val is_a_literal_case : - literal_cases:Ast_untagged_variants.tag_type list -> - block_cases:Ast_untagged_variants.block_type list -> + literal_cases:Variant_runtime.tag_type list -> + block_cases:Variant_runtime.block_type list -> t -> t diff --git a/compiler/core/js_of_lam_variant.ml b/compiler/core/js_of_lam_variant.ml index 11b7e3a2fb8..8cb33ed7dae 100644 --- a/compiler/core/js_of_lam_variant.ml +++ b/compiler/core/js_of_lam_variant.ml @@ -40,7 +40,7 @@ let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = [ S.string_switch arg (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, + ( Variant_runtime.String s, J. { switch_body = [S.return_stmt (E.str r)]; @@ -81,7 +81,7 @@ let eval_as_event (arg : J.expression) S.string_switch (E.poly_var_tag_access arg) (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, + ( Variant_runtime.String s, J. { switch_body = [S.return_stmt (E.str r)]; @@ -110,7 +110,7 @@ let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t = [ S.string_switch arg (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, + ( Variant_runtime.String s, J. { switch_body = [S.return_stmt (E.int (Int32.of_int r))]; diff --git a/compiler/core/js_stmt_make.ml b/compiler/core/js_stmt_make.ml index 5a794bdeb44..3c65adf4a98 100644 --- a/compiler/core/js_stmt_make.ml +++ b/compiler/core/js_stmt_make.ml @@ -142,7 +142,7 @@ let int_switch ?(comment : string option) let string_switch ?(comment : string option) ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) (e : J.expression) - (clauses : (Ast_untagged_variants.tag_type * J.case_clause) list) : t = + (clauses : (Variant_runtime.tag_type * J.case_clause) list) : t = match e.expression_desc with | Str {txt} -> ( let continuation = diff --git a/compiler/core/js_stmt_make.mli b/compiler/core/js_stmt_make.mli index 04a3feac3ef..98759f2caf2 100644 --- a/compiler/core/js_stmt_make.mli +++ b/compiler/core/js_stmt_make.mli @@ -73,7 +73,7 @@ val string_switch : ?declaration:Lam_compat.let_kind * Ident.t -> ?default:J.block -> J.expression -> - (Ast_untagged_variants.tag_type * J.case_clause) list -> + (Variant_runtime.tag_type * J.case_clause) list -> t val declare_variable : diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index d2d4ca67610..67c8a758afc 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -295,7 +295,7 @@ let switch lam (lam_switch : lambda_switch) : t = match key with | Lambda.Switch_int ordinal when ordinal = i -> Some action | Switch_constructor - (Constant {tag_type = Some (Ast_untagged_variants.Int value)}) + (Constant {tag_type = Some (Variant_runtime.Int value)}) when comment = None && value = i -> Some action | Switch_int _ | Switch_constructor _ -> None) diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 1fc62503cdf..7469b0ddc0c 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -218,7 +218,7 @@ let dispatch_info = function | Lambda.Switch_direct -> (Js_dump_lit.tag, [], [], (false, false, false)) | Switch_variant { - Ast_untagged_variants.tag_name; + Variant_runtime.tag_name; block_types; literal_tags; has_null; @@ -690,7 +690,7 @@ let compile output_prefix = List.fold_right (fun (key, lam) acc -> match (tag_of_switch_key key, acc) with - | Some {Ast_untagged_variants.tag_type = Some t}, Some string_table -> + | Some {Variant_runtime.tag_type = Some t}, Some string_table -> Some ((t, lam) :: string_table) | Some {name; tag_type = None}, Some string_table -> Some ((String name, lam) :: string_table) @@ -786,9 +786,7 @@ let compile output_prefix = && List.length sw_consts = 0 && eq_default sw_num_default sw_blocks_default then - let has_null_case = - List.mem Ast_untagged_variants.Null literal_cases - in + let has_null_case = List.mem Variant_runtime.Null literal_cases in compile_cases ~untagged ~cxt ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) ~block_cases ~has_null_case ~default:sw_blocks_default sw_blocks @@ -838,7 +836,7 @@ let compile output_prefix = ~switch_exp ~default and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases ~has_null_case cases = - let mk_eq (i : Ast_untagged_variants.tag_type option) x j y = + let mk_eq (i : Variant_runtime.tag_type option) x j y = let check = match (i, j) with | Some tag_type, _ -> @@ -852,7 +850,7 @@ let compile output_prefix = E.emit_check check in let tag_is_not_typeof = function - | Ast_untagged_variants.Untagged (InstanceType _) -> true + | Variant_runtime.Untagged (InstanceType _) -> true | _ -> false in let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in @@ -863,21 +861,21 @@ let compile output_prefix = let has_object_typeof = List.exists (function - | Ast_untagged_variants.Untagged ObjectType, _ -> true + | Variant_runtime.Untagged ObjectType, _ -> true | _ -> false) typeof_clauses in let clauses_have_array_case = List.exists (function - | Ast_untagged_variants.Untagged (InstanceType Array), _ -> true + | Variant_runtime.Untagged (InstanceType Array), _ -> true | _ -> false) not_typeof_clauses in let type_has_array_case = List.exists (function - | Ast_untagged_variants.InstanceType Array -> true + | Variant_runtime.InstanceType Array -> true | _ -> false) block_cases in @@ -890,7 +888,7 @@ let compile output_prefix = in let rec build_if_chain remaining_clauses = match remaining_clauses with - | ( Ast_untagged_variants.Untagged (InstanceType instance_type), + | ( Variant_runtime.Untagged (InstanceType instance_type), {J.switch_body} ) :: rest -> S.if_ @@ -930,7 +928,7 @@ let compile output_prefix = The [gen] can be elimiated when number of [cases] is less than 3 *) let cases = - cases |> List.map (fun (s, l) -> (Ast_untagged_variants.String s, l)) + cases |> List.map (fun (s, l) -> (Variant_runtime.String s, l)) in match compile_lambda {lambda_cxt with continuation = NeedValue Not_tail} l diff --git a/compiler/core/lam_constant_convert.ml b/compiler/core/lam_constant_convert.ml index c91c3a57e73..7d5b58ad47f 100644 --- a/compiler/core/lam_constant_convert.ml +++ b/compiler/core/lam_constant_convert.ml @@ -42,7 +42,7 @@ let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = | Pt_module_alias -> Const_module_alias | Pt_shape_none -> Lam_constant.lam_none | Pt_assertfalse -> Const_int {i = 0l; comment = Pt_assertfalse} - | Pt_constructor {tag_type = Some (Ast_untagged_variants.Int v)} -> + | Pt_constructor {tag_type = Some (Variant_runtime.Int v)} -> (* A constructor represented as a number is a genuine number at runtime; folding relies on it being an ordinary int constant *) Const_int {i = Int32.of_int v; comment = None} diff --git a/compiler/frontend/lam_constant.ml b/compiler/frontend/lam_constant.ml index 23d02053bfe..31e3a542cb6 100644 --- a/compiler/frontend/lam_constant.ml +++ b/compiler/frontend/lam_constant.ml @@ -36,7 +36,7 @@ type t = | Const_js_true | Const_js_false | Const_int of {i: int32; comment: pointer_info} - | Const_constructor of Ast_untagged_variants.tag + | Const_constructor of Variant_runtime.tag (* Constant constructor of a nominal variant, emitted from its canonical runtime descriptor rather than an ordinal *) | Const_char of int diff --git a/compiler/frontend/lam_constant.mli b/compiler/frontend/lam_constant.mli index bcef7a00ae2..ab375f87698 100644 --- a/compiler/frontend/lam_constant.mli +++ b/compiler/frontend/lam_constant.mli @@ -32,7 +32,7 @@ type t = | Const_js_true | Const_js_false | Const_int of {i: int32; comment: pointer_info} - | Const_constructor of Ast_untagged_variants.tag + | Const_constructor of Variant_runtime.tag (* Constant constructor of a nominal variant, emitted from its canonical runtime descriptor rather than an ordinal *) | Const_char of int diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index cf81d1e5516..dd642a21be0 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -1,4 +1,4 @@ -module Instance = Variant_runtime.Instance +open Variant_runtime type untagged_error = | OnlyOneUnknown of string @@ -58,17 +58,6 @@ let report_error ppf = rename the field." constructor_name runtime_value field_name -type block_type = Variant_runtime.block_type = - | IntType - | StringType - | FloatType - | BigintType - | BooleanType - | InstanceType of Instance.t - | FunctionType - | ObjectType - | UnknownType - let block_type_to_user_visible_string = function | IntType -> "int" | StringType -> "string" @@ -85,60 +74,6 @@ let block_type_to_user_visible_string = function Can be a literal (case with no payload), or a block (case with payload). In the case of block it can be tagged or untagged. *) -type tag_type = Variant_runtime.tag_type = - | String of string - | Int of int - | Float of string - | BigInt of string - | Bool of bool - | Null - | Undefined (* literal or tagged block *) - | Untagged of block_type (* untagged block *) -type tag = Variant_runtime.tag = {name: string; tag_type: tag_type option} - -type block_runtime = Variant_runtime.block_runtime = { - tag: tag; - tag_name: string option; - untagged: bool; -} -(** Runtime information shared by construction and pattern matching for a - constructor carrying a payload. [block_type] is deliberately not part of - this value: it describes how a matcher recognizes an unboxed payload, not - how the value itself is constructed. *) - -type block = Variant_runtime.block = { - runtime: block_runtime; - block_type: block_type option; -} - -type constructor_case = Variant_runtime.constructor_case = - | Constant of tag - | Block of block - -type variant_layout = Variant_runtime.variant_layout = { - constructors: constructor_case array; - constructors_by_name: (int * constructor_case) Map_string.t; - dispatch: Variant_runtime.variant_dispatch; -} -(** Canonical runtime layout in source-constructor order. *) - -type variant_dispatch = Variant_runtime.variant_dispatch = { - tag_name: string option; - block_types: block_type list; - literal_tags: tag_type list; - has_null: bool; - has_undefined: bool; - has_other_literal: bool; -} -(** The whole-variant information needed to choose a JavaScript dispatch - strategy. Constructor identity is carried by each switch arm instead. *) - -let constructor_by_name layout name = - snd (Map_string.find_exn layout.constructors_by_name name) - -let constructor_position layout name = - fst (Map_string.find_exn layout.constructors_by_name name) - let tag_type_to_user_visible_string = function | String _ -> "string" | Int _ -> "int" diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index fa81e8d4e44..87be91b83f8 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -100,6 +100,22 @@ let constructor_has_optional_shape ({cstr_attributes = attrs} : constructor_description) = List.exists (fun (x, _) -> x.txt = internal_optional) attrs +(* The constructor's entry in its variant's canonical layout *) +let constructor_case (cstr : constructor_description) = + match cstr.cstr_layout with + | Some layout -> Variant_runtime.constructor_by_name layout cstr.cstr_name + | None -> assert false + +(* Sole payload-carrying constructor of an unboxed type: constructing it is + the identity at runtime *) +let constructor_is_transparent (cstr : constructor_description) = + (match cstr.cstr_layout with + | Some [|Block _|] -> true + | _ -> false) + && List.exists + (fun (attribute, _) -> attribute.txt = "unboxed") + cstr.cstr_attributes + let constructor_descrs ty_path decl cstrs = let layout = match decl.type_kind with @@ -107,11 +123,7 @@ let constructor_descrs ty_path decl cstrs = | Type_abstract | Type_record _ | Type_open -> assert false in let ty_res = newgenconstr ty_path decl.type_params in - let num_consts = ref 0 and num_nonconsts = ref 0 in - List.iter - (fun {cd_args; _} -> - if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) - cstrs; + let num_nonconsts = Variant_runtime.num_blocks layout in let rec describe_constructors = function | [] -> [] | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> @@ -127,11 +139,7 @@ let constructor_descrs ty_path decl cstrs = if decl.type_representation = Transparent then Record_unboxed true else Record_inlined - { - name = cstr_name; - num_nonconsts = !num_nonconsts; - attrs = cd_attributes; - } + {name = cstr_name; num_nonconsts; attrs = cd_attributes} in constructor_args decl.type_private cd_args cd_res (Path.Pdot (ty_path, cstr_name, Path.nopos)) @@ -146,11 +154,6 @@ let constructor_descrs ty_path decl cstrs = cstr_arity = List.length cstr_args; cstr_kind = Ordinary_constructor; cstr_layout = Some layout; - cstr_transparent = - !num_consts = 0 && !num_nonconsts = 1 && cstr_args <> [] - && List.exists - (fun (attribute, _) -> attribute.txt = "unboxed") - cd_attributes; cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; @@ -202,7 +205,6 @@ let extension_descr path_ext ext = cstr_arity = List.length cstr_args; cstr_kind = Extension_constructor path_ext; cstr_layout = None; - cstr_transparent = false; cstr_private = ext.ext_private; cstr_generalized = ext.ext_ret_type <> None; cstr_loc = ext.ext_loc; diff --git a/compiler/ml/datarepr.mli b/compiler/ml/datarepr.mli index 9161eb77ac9..de7572575bb 100644 --- a/compiler/ml/datarepr.mli +++ b/compiler/ml/datarepr.mli @@ -19,6 +19,9 @@ open Types val constructor_has_optional_shape : Types.constructor_description -> bool +val constructor_case : + Types.constructor_description -> Variant_runtime.constructor_case +val constructor_is_transparent : Types.constructor_description -> bool val extension_descr : Path.t -> extension_constructor -> constructor_description diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 9f1abcb9bb5..9a933465ea1 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -19,14 +19,14 @@ type tag_info = | Blk_constructor of { name: string; num_nonconst: int; - runtime: Ast_untagged_variants.block_runtime; + runtime: Variant_runtime.block_runtime; } | Blk_record_inlined of { name: string; num_nonconst: int; fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; - runtime: Ast_untagged_variants.block_runtime; + runtime: Variant_runtime.block_runtime; } | Blk_tuple | Blk_poly_var of string @@ -310,7 +310,7 @@ and value_kind = Pgenval and raise_kind = Raise_regular | Raise_reraise type pointer_info = - | Pt_constructor of Ast_untagged_variants.tag + | Pt_constructor of Variant_runtime.tag | Pt_variant of {name: string} | Pt_module_alias | Pt_shape_none @@ -381,11 +381,11 @@ and lambda_apply = { and switch_key = | Switch_int of int - | Switch_constructor of Ast_untagged_variants.constructor_case + | Switch_constructor of Variant_runtime.constructor_case and switch_dispatch = | Switch_direct - | Switch_variant of Ast_untagged_variants.variant_dispatch + | Switch_variant of Variant_runtime.variant_dispatch and 'a switch = { sw_consts_full: bool; @@ -403,8 +403,7 @@ and lambda_switch = lambda switch alias etc. *) let const_unit = - Const_pointer - (Pt_constructor {Ast_untagged_variants.name = "()"; tag_type = None}) + Const_pointer (Pt_constructor {Variant_runtime.name = "()"; tag_type = None}) let lambda_assert_false = Lconst (Const_pointer Pt_assertfalse) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 329bdc38b92..ecc77d31148 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -23,14 +23,14 @@ type tag_info = | Blk_constructor of { name: string; num_nonconst: int; - runtime: Ast_untagged_variants.block_runtime; + runtime: Variant_runtime.block_runtime; } | Blk_record_inlined of { name: string; num_nonconst: int; fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; - runtime: Ast_untagged_variants.block_runtime; + runtime: Variant_runtime.block_runtime; } | Blk_tuple | Blk_poly_var of string @@ -73,7 +73,7 @@ val blk_record_inlined : (Types.label_description * Typedtree.record_label_definition * bool) array -> string -> int -> - runtime:Ast_untagged_variants.block_runtime -> + runtime:Variant_runtime.block_runtime -> mutable_flag -> tag_info @@ -115,7 +115,7 @@ val fld_record_extension_set : Types.label_description -> set_field_dbg_info type immediate_or_pointer = Immediate | Pointer type pointer_info = - | Pt_constructor of Ast_untagged_variants.tag + | Pt_constructor of Variant_runtime.tag | Pt_variant of {name: string} | Pt_module_alias | Pt_shape_none @@ -353,11 +353,11 @@ and lambda_apply = { and switch_key = | Switch_int of int - | Switch_constructor of Ast_untagged_variants.constructor_case + | Switch_constructor of Variant_runtime.constructor_case and switch_dispatch = | Switch_direct - | Switch_variant of Ast_untagged_variants.variant_dispatch + | Switch_variant of Variant_runtime.variant_dispatch and 'a switch = { sw_consts_full: bool; diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 0e9a9bcd5d9..1a2d090adcb 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -2041,14 +2041,13 @@ let sort_constructor_cases layout cases = List.sort (fun (cstr1, _) (cstr2, _) -> let index cstr = - Ast_untagged_variants.constructor_position layout cstr.cstr_name + Variant_runtime.constructor_position layout cstr.cstr_name in Int.compare (index cstr1) (index cstr2)) cases let constructor_switch_key layout (cstr : Types.constructor_description) = - Switch_constructor - (Ast_untagged_variants.constructor_by_name layout cstr.cstr_name) + Switch_constructor (Variant_runtime.constructor_by_name layout cstr.cstr_name) let combine_constructor loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = @@ -2092,18 +2091,10 @@ let combine_constructor loc arg ex_pat cstr partial ctx def | Some layout -> layout | None -> assert false in - let num_consts, num_nonconsts = - Array.fold_left - (fun (consts, nonconsts) (case : Ast_untagged_variants.constructor_case) - -> - match case with - | Constant _ -> (consts + 1, nonconsts) - | Block _ -> (consts, nonconsts + 1)) - (0, 0) layout.Ast_untagged_variants.constructors - in - let ncases = List.length tag_lambda_list - and nconstrs = num_consts + num_nonconsts in - let sig_complete = ncases = nconstrs in + let num_consts = Variant_runtime.num_constants layout + and num_nonconsts = Variant_runtime.num_blocks layout in + let ncases = List.length tag_lambda_list in + let sig_complete = ncases = Array.length layout in let fail_opt, fails, local_jumps = if sig_complete then (None, [], jumps_empty) else mk_failaction_pos partial pats ctx def @@ -2165,7 +2156,7 @@ let combine_constructor loc arg ex_pat cstr partial ctx def sw_blocks_full = List.length nonconsts >= num_nonconsts; sw_blocks = nonconsts; sw_failaction = fail_opt; - sw_dispatch = Switch_variant layout.dispatch; + sw_dispatch = Switch_variant (Variant_runtime.dispatch layout); } in let hs, sw = share_actions_sw sw in diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 6f2d1ccecd2..05c74198b27 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -563,9 +563,7 @@ let all_record_args lbls = match cd.cstr_layout with | None -> x | Some layout -> ( - match - Ast_untagged_variants.constructor_by_name layout cd.cstr_name - with + match Variant_runtime.constructor_by_name layout cd.cstr_name with | Block {block_type = Some block_type} when not (Ast_untagged_variants.block_type_can_be_undefined @@ -861,12 +859,10 @@ let row_of_pat pat = let full_match closing env = match env with - | (({pat_desc = Tpat_construct (_, c, _)} as p), _) :: _ -> ( - match c.cstr_kind with - | Extension_constructor _ -> false - | Ordinary_constructor -> - List.length env - = List.length (get_variant_constructors p.pat_env c.cstr_res)) + | ({pat_desc = Tpat_construct (_, c, _)}, _) :: _ -> ( + match c.cstr_layout with + | None -> false (* extensions *) + | Some layout -> List.length env = Array.length layout) | (({pat_desc = Tpat_variant _} as p), _) :: _ -> let fields = List.map diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 0bdc7516904..86e4f6e542b 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -268,7 +268,9 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Extension_constructor pth -> Use.inspect (path env pth) | _ -> Use.empty in - let use = if desc.cstr_transparent then fun x -> x else Use.guard in + let use = + if Datarepr.constructor_is_transparent desc then fun x -> x else Use.guard + in Use.join access_constructor (use (list expression env exprs)) | Texp_variant (_, eo) -> Use.guard (option expression env eo) | Texp_record {fields = es; extended_expression = eo; representation = rep} -> diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 77c658d4b34..26db8023993 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -38,13 +38,7 @@ let transl_module = [cstr]; part of the runtime representation of its blocks *) let num_nonconst_constructors (cstr : Types.constructor_description) = match cstr.cstr_layout with - | Some layout -> - Array.fold_left - (fun n (case : Variant_runtime.constructor_case) -> - match case with - | Block _ -> n + 1 - | Constant _ -> n) - 0 layout.constructors + | Some layout -> Variant_runtime.num_blocks layout | None -> assert false (* Compile an exception/extension definition *) @@ -781,14 +775,16 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none else Pt_constructor - (Ast_untagged_variants.constructor_tag ~name:cstr.cstr_name - cstr.cstr_attributes))) + (match Datarepr.constructor_case cstr with + | Constant tag -> tag + | Block _ -> assert false))) | Ordinary_constructor -> ( let runtime = - Ast_untagged_variants.block_runtime ~name:cstr.cstr_name - cstr.cstr_attributes + match Datarepr.constructor_case cstr with + | Block {runtime} -> runtime + | Constant _ -> assert false in - if cstr.cstr_transparent then + if Datarepr.constructor_is_transparent cstr then match ll with | [value] -> value | _ -> assert false diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index afbd287c82f..f00b3082d77 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -254,9 +254,6 @@ type constructor_description = { cstr_layout: Variant_runtime.variant_layout option; (* Runtime layout of the declaring variant; None for extension constructors *) - cstr_transparent: bool; - (* Sole payload-carrying constructor of an unboxed type: constructing - it is the identity at runtime *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index dfc62dd924c..07ef083c90d 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -358,9 +358,6 @@ type constructor_description = { cstr_layout: Variant_runtime.variant_layout option; (* Runtime layout of the declaring variant; None for extension constructors *) - cstr_transparent: bool; - (* Sole payload-carrying constructor of an unboxed type: constructing - it is the identity at runtime *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index d798d289753..a98db56e4bc 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -6,12 +6,12 @@ type variant_runtime_representation_issue = | Mismatched_as_payload of { constructor_name: string; expected_typename: Path.t; - as_payload: Ast_untagged_variants.tag_type option; + as_payload: Variant_runtime.tag_type option; } | As_payload_not_elgible_for_coercion of { constructor_name: string; expected_typename: Path.t; - as_payload: Ast_untagged_variants.tag_type; + as_payload: Variant_runtime.tag_type; } | Inline_record_cannot_be_coerced of {constructor_name: string} | Cannot_coerce_non_unboxed_with_payload of { diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index bdb5c8cdf71..93b02d834ad 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -5,6 +5,7 @@ [Type_variant] and never re-derived. It lives above [Ctype] because classifying untagged payloads requires expanding their types. *) +open Variant_runtime open Ast_untagged_variants let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = @@ -88,20 +89,4 @@ let layout_from_type_variant ?(is_untagged_def = false) ~env Array.of_list (List.map (fun (_, constructor) -> constructor) located_constructors) in - let constructors_by_name = - let _, constructors_by_name = - List.fold_left2 - (fun (index, constructors_by_name) - (cstr : Types.constructor_declaration) (_, constructor) -> - ( index + 1, - Map_string.add constructors_by_name (Ident.name cstr.cd_id) - (index, constructor) )) - (0, Map_string.empty) cstrs located_constructors - in - constructors_by_name - in - { - constructors; - constructors_by_name; - dispatch = Variant_runtime.dispatch_of_constructors constructors; - } + constructors diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index a3b4f492cce..ee8085349c4 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -104,16 +104,42 @@ type variant_dispatch = { (** The whole-variant information needed to choose a JavaScript dispatch strategy. Constructor identity is carried by each switch arm instead. *) -type variant_layout = { - constructors: constructor_case array; - constructors_by_name: (int * constructor_case) Map_string.t; - dispatch: variant_dispatch; -} -(** Canonical runtime layout in source-constructor order, with the - precomputed dispatch strategy. *) +type variant_layout = constructor_case array +(** Canonical runtime layout in source-constructor order. *) + +let case_name = function + | Constant {name} -> name + | Block {runtime = {tag = {name}}} -> name + +let constructor_position (layout : variant_layout) name = + let rec find i = + if i >= Array.length layout then + invalid_arg ("Variant_runtime.constructor_position: " ^ name) + else if case_name layout.(i) = name then i + else find (i + 1) + in + find 0 + +let constructor_by_name (layout : variant_layout) name = + layout.(constructor_position layout name) + +let num_constants (layout : variant_layout) = + Array.fold_left + (fun n case -> + match case with + | Constant _ -> n + 1 + | Block _ -> n) + 0 layout + +let num_blocks (layout : variant_layout) = + Array.fold_left + (fun n case -> + match case with + | Block _ -> n + 1 + | Constant _ -> n) + 0 layout -let dispatch_of_constructors (constructors : constructor_case array) : - variant_dispatch = +let dispatch (constructors : variant_layout) : variant_dispatch = let tag_name = ref None in let block_types = ref [] in let literal_tags = ref [] in @@ -152,16 +178,12 @@ let dispatch_of_constructors (constructors : constructor_case array) : (* Placeholder used while a recursive declaration group is being typed; [Typedecl] replaces it with the computed layout once the group is in the environment *) -let dummy_layout = - { - constructors = [||]; - constructors_by_name = Map_string.empty; - dispatch = dispatch_of_constructors [||]; - } +let dummy_layout : variant_layout = [||] (* Layout of a variant that carries no representation attributes; used for predefined types, whose declarations are built by hand *) -let plain_layout (cases : (string * bool (* has payload *)) list) = +let plain_layout (cases : (string * bool (* has payload *)) list) : + variant_layout = let case (name, has_payload) = if has_payload then Block @@ -172,15 +194,4 @@ let plain_layout (cases : (string * bool (* has payload *)) list) = } else Constant {name; tag_type = None} in - let constructors = Array.of_list (List.map case cases) in - let _, constructors_by_name = - List.fold_left - (fun (index, by_name) (name, _) -> - (index + 1, Map_string.add by_name name (index, constructors.(index)))) - (0, Map_string.empty) cases - in - { - constructors; - constructors_by_name; - dispatch = dispatch_of_constructors constructors; - } + Array.of_list (List.map case cases) From 71ce1d6d93928a0dbaa46cea4de47428f0efb479 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 25 Aug 2026 10:41:17 +0200 Subject: [PATCH 6/7] Separate variant layouts from constructor matching plans The runtime representation of a variant is declaration-level data, while the decision for a particular match depends on its arms, actions, default, and exhaustiveness. Represent the two separately: - Variant_runtime.layout stores immutable constructor representations and declaration-level matching facts computed once. - Type_variant stores an abstract one-shot layout_ref. Recursive declarations allocate it while provisional, then complete the same identity after the recursive group is available. - Ordinary constructor descriptions address their representation by layout reference and source position, removing repeated name lookup and duplicated layout storage. - Matching builds one occurrence-specific constructor_matching_plan in combine_constructor and immediately lowers it to existing Lambda forms. No Lam or Lambda expression form is added. - Construction, matching, and type-based optimization consume the canonical representation instead of reinterpreting runtime attributes. Rename Transparent to Unboxed and variant_dispatch to matching_facts so the remaining terms describe the represented facts rather than an implementation strategy. Signed-off-by: Cristiano Calcagno --- compiler/ml/datarepr.ml | 73 +++++++---- compiler/ml/datarepr.mli | 6 +- compiler/ml/includecore.ml | 4 +- compiler/ml/lambda.ml | 2 +- compiler/ml/lambda.mli | 2 +- compiler/ml/matching.ml | 187 ++++++++++++++++------------ compiler/ml/parmatch.ml | 22 ++-- compiler/ml/predef.ml | 2 +- compiler/ml/printtyp.ml | 2 +- compiler/ml/rec_check.ml | 2 +- compiler/ml/translcore.ml | 42 ++++--- compiler/ml/typecore_record_rest.ml | 15 ++- compiler/ml/typedecl.ml | 15 +-- compiler/ml/typeopt.ml | 49 +++++--- compiler/ml/types.ml | 30 +++-- compiler/ml/types.mli | 21 ++-- compiler/ml/variant_layout.ml | 5 +- compiler/ml/variant_runtime.ml | 96 +++++++++----- compiler/ml/variant_runtime.mli | 80 ++++++++++++ 19 files changed, 417 insertions(+), 238 deletions(-) create mode 100644 compiler/ml/variant_runtime.mli diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index 87be91b83f8..f4b63fb30d6 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -70,7 +70,7 @@ let constructor_args priv cd_args cd_res path rep = let type_params = Type_set.elements arg_vars_set in let type_representation = match rep with - | Record_unboxed _ -> Transparent + | Record_unboxed _ -> Unboxed | _ -> Boxed in let tdecl = @@ -102,19 +102,37 @@ let constructor_has_optional_shape (* The constructor's entry in its variant's canonical layout *) let constructor_case (cstr : constructor_description) = - match cstr.cstr_layout with - | Some layout -> Variant_runtime.constructor_by_name layout cstr.cstr_name - | None -> assert false + match cstr.cstr_kind with + | Ordinary_constructor representation -> + Variant_runtime.representation representation + | Extension_constructor _ -> assert false -(* Sole payload-carrying constructor of an unboxed type: constructing it is - the identity at runtime *) -let constructor_is_transparent (cstr : constructor_description) = - (match cstr.cstr_layout with - | Some [|Block _|] -> true - | _ -> false) - && List.exists - (fun (attribute, _) -> attribute.txt = "unboxed") - cstr.cstr_attributes +let constructor_variant (cstr : constructor_description) = + match cstr.cstr_kind with + | Ordinary_constructor {variant} -> Variant_runtime.get_layout variant + | Extension_constructor _ -> assert false + +let constructor_position (cstr : constructor_description) = + match cstr.cstr_kind with + | Ordinary_constructor {position} -> position + | Extension_constructor _ -> assert false + +let constructor_payload_is_unboxed (cstr : constructor_description) = + match cstr.cstr_kind with + | Ordinary_constructor representation -> ( + match Variant_runtime.representation representation with + | Block {runtime = {untagged = true}} -> true + | Constant _ | Block _ -> false) + | Extension_constructor _ -> false + +(* Sole payload-carrying constructor of an @unboxed type: constructing it is + the identity at runtime. *) +let constructor_is_unboxed (cstr : constructor_description) = + match cstr.cstr_kind with + | Ordinary_constructor {variant} -> + constructor_payload_is_unboxed cstr + && Variant_runtime.length (Variant_runtime.get_layout variant) = 1 + | Extension_constructor _ -> false let constructor_descrs ty_path decl cstrs = let layout = @@ -123,8 +141,7 @@ let constructor_descrs ty_path decl cstrs = | Type_abstract | Type_record _ | Type_open -> assert false in let ty_res = newgenconstr ty_path decl.type_params in - let num_nonconsts = Variant_runtime.num_blocks layout in - let rec describe_constructors = function + let rec describe_constructors position = function | [] -> [] | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> let ty_res = @@ -132,18 +149,24 @@ let constructor_descrs ty_path decl cstrs = | Some ty_res' -> ty_res' | None -> ty_res in - let descr_rem = describe_constructors rem in + let descr_rem = describe_constructors (position + 1) rem in let cstr_name = Ident.name cd_id in + let representation : Variant_runtime.constructor_reference = + {variant = layout; position} + in let existentials, cstr_args, cstr_inlined = - let representation = - if decl.type_representation = Transparent then Record_unboxed true - else - Record_inlined - {name = cstr_name; num_nonconsts; attrs = cd_attributes} + let record_representation = + match cd_args with + | Cstr_tuple _ -> + (* [constructor_args] ignores this value for tuple payloads. *) + Record_regular + | Cstr_record _ when decl.type_representation = Unboxed -> + Record_unboxed true + | Cstr_record _ -> Record_inlined {name = cstr_name; representation} in constructor_args decl.type_private cd_args cd_res (Path.Pdot (ty_path, cstr_name, Path.nopos)) - representation + record_representation in let cstr = { @@ -152,8 +175,7 @@ let constructor_descrs ty_path decl cstrs = cstr_existentials = existentials; cstr_args; cstr_arity = List.length cstr_args; - cstr_kind = Ordinary_constructor; - cstr_layout = Some layout; + cstr_kind = Ordinary_constructor representation; cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; @@ -163,7 +185,7 @@ let constructor_descrs ty_path decl cstrs = in (cd_id, cstr) :: descr_rem in - let result = describe_constructors cstrs in + let result = describe_constructors 0 cstrs in match result with | [ (({Ident.name = "None"} as a_id), ({cstr_args = []} as a_descr)); @@ -204,7 +226,6 @@ let extension_descr path_ext ext = cstr_args; cstr_arity = List.length cstr_args; cstr_kind = Extension_constructor path_ext; - cstr_layout = None; cstr_private = ext.ext_private; cstr_generalized = ext.ext_ret_type <> None; cstr_loc = ext.ext_loc; diff --git a/compiler/ml/datarepr.mli b/compiler/ml/datarepr.mli index de7572575bb..5996ebe278f 100644 --- a/compiler/ml/datarepr.mli +++ b/compiler/ml/datarepr.mli @@ -21,7 +21,11 @@ open Types val constructor_has_optional_shape : Types.constructor_description -> bool val constructor_case : Types.constructor_description -> Variant_runtime.constructor_case -val constructor_is_transparent : Types.constructor_description -> bool +val constructor_variant : + Types.constructor_description -> Variant_runtime.layout +val constructor_position : Types.constructor_description -> int +val constructor_payload_is_unboxed : Types.constructor_description -> bool +val constructor_is_unboxed : Types.constructor_description -> bool val extension_descr : Path.t -> extension_constructor -> constructor_description diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index 34f7913337d..e41a2122836 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -350,8 +350,8 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = in match ( decl2.type_kind, - decl1.type_representation = Transparent || untagged1, - decl2.type_representation = Transparent || untagged2 ) + decl1.type_representation = Unboxed || untagged1, + decl2.type_representation = Unboxed || untagged2 ) with | Type_abstract, _, _ -> [] | _, true, false -> [Unboxed_representation false] diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 9a933465ea1..4184139da04 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -385,7 +385,7 @@ and switch_key = and switch_dispatch = | Switch_direct - | Switch_variant of Variant_runtime.variant_dispatch + | Switch_variant of Variant_runtime.matching_facts and 'a switch = { sw_consts_full: bool; diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index ecc77d31148..ce93f9f3274 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -357,7 +357,7 @@ and switch_key = and switch_dispatch = | Switch_direct - | Switch_variant of Variant_runtime.variant_dispatch + | Switch_variant of Variant_runtime.matching_facts and 'a switch = { sw_consts_full: bool; diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 1a2d090adcb..efdafc169c0 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1266,13 +1266,14 @@ let make_constr_matching p def ctx = function | [] -> fatal_error "Matching.make_constr_matching" | (arg, _mut) :: argl -> let cstr = pat_as_constr p in - let untagged = Ast_untagged_variants.has_untagged cstr.cstr_attributes in + let payload_is_unboxed = Datarepr.constructor_payload_is_unboxed cstr in let newargs = - if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then - (arg, Alias) :: argl + if + cstr.cstr_inlined <> None || (payload_is_unboxed && cstr.cstr_args <> []) + then (arg, Alias) :: argl else match cstr.cstr_kind with - | Ordinary_constructor + | Ordinary_constructor _ when cstr.cstr_args <> [] && Datarepr.constructor_has_optional_shape cstr -> let from_option = @@ -1283,7 +1284,7 @@ let make_constr_matching p def ctx = function | _ -> Pval_from_option in (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl - | Ordinary_constructor -> + | Ordinary_constructor _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) | Extension_constructor _ -> @@ -2006,7 +2007,7 @@ let split_cases tag_lambda_list = | (cstr, act) :: rem -> ( let consts, nonconsts = split_rec rem in match cstr.cstr_kind with - | Ordinary_constructor -> + | Ordinary_constructor _ -> if cstr.cstr_args = [] then ((cstr, act) :: consts, nonconsts) else (consts, (cstr, act) :: nonconsts) | Extension_constructor _ -> assert false) @@ -2033,28 +2034,110 @@ let get_extension_cases tag_lambda_list = let nonconsts = split_rec rem in match cstr.cstr_kind with | Extension_constructor path -> (path, act) :: nonconsts - | Ordinary_constructor -> assert false) + | Ordinary_constructor _ -> assert false) in split_rec tag_lambda_list -let sort_constructor_cases layout cases = +let sort_constructor_cases cases = List.sort (fun (cstr1, _) (cstr2, _) -> - let index cstr = - Variant_runtime.constructor_position layout cstr.cstr_name - in - Int.compare (index cstr1) (index cstr2)) + Int.compare + (Datarepr.constructor_position cstr1) + (Datarepr.constructor_position cstr2)) cases -let constructor_switch_key layout (cstr : Types.constructor_description) = - Switch_constructor (Variant_runtime.constructor_by_name layout cstr.cstr_name) +let constructor_switch_key (cstr : Types.constructor_description) = + Switch_constructor (Datarepr.constructor_case cstr) + +(* An occurrence-specific plan for one constructor decision-tree node. It is + deliberately local to pattern matching: [lower_constructor_matching_plan] + immediately expresses the decision with existing Lambda control-flow + nodes, so Lambda and Lam do not acquire another expression language. *) +type payload_presence_test = Is_present_option | Is_nonempty_list + +type constructor_matching_plan = + | Use_constructor_action of Lambda.lambda + (** Every possible constructor reaches the same action. *) + | Test_payload_presence of { + test: payload_presence_test; + absent: Lambda.lambda; + present: Lambda.lambda; + } + (** A two-constructor representation whose runtime value directly + reveals whether the payload constructor is present. *) + | Test_boolean_value of {if_false: Lambda.lambda; if_true: Lambda.lambda} + (** The predefined boolean constructors are JavaScript booleans. *) + | Switch_on_constructors of Lambda.lambda_switch + (** General nominal and untagged variant matching. *) + +let lower_constructor_matching_plan ~loc ~arg = function + | Use_constructor_action action -> action + | Test_payload_presence {test; absent; present} -> + let condition = + match test with + | Is_present_option -> Lprim (Pis_not_none, [arg], loc) + | Is_nonempty_list -> + Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) + in + Lifthenelse (condition, present, absent) + | Test_boolean_value {if_false; if_true} -> + Lifthenelse (arg, if_true, if_false) + | Switch_on_constructors sw -> + let hs, sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg, sw, loc)) + +let make_constructor_matching_plan ~cstr ~(layout : Variant_runtime.layout) + ~fail_opt ~num_consts ~num_nonconsts ~tag_lambda_list ~consts ~nonconsts = + match (fail_opt, same_actions tag_lambda_list) with + | None, Some action -> Use_constructor_action action + | _ -> ( + match (num_consts, num_nonconsts, consts, nonconsts) with + | 1, 1, [(_, absent)], [(_, present)] + when cstr.cstr_name = "::" || cstr.cstr_name = "[]" + || Datarepr.constructor_has_optional_shape cstr -> + Test_payload_presence + { + test = + (if Datarepr.constructor_has_optional_shape cstr then + Is_present_option + else Is_nonempty_list); + absent; + present; + } + | 2, 0, _, [] when cstr.cstr_name = "true" || cstr.cstr_name = "false" -> + let find_action name = + match + Ext_list.find_opt consts (fun (cstr, action) -> + if cstr.cstr_name = name then Some action else None) + with + | Some action -> action + | None -> assert false + in + Test_boolean_value + {if_false = find_action "false"; if_true = find_action "true"} + | _, _, _, _ -> + let switch_cases cases = + List.map + (fun (cstr, action) -> (constructor_switch_key cstr, action)) + cases + in + Switch_on_constructors + { + sw_consts_full = List.length consts >= num_consts; + sw_consts = switch_cases consts; + sw_blocks_full = List.length nonconsts >= num_nonconsts; + sw_blocks = switch_cases nonconsts; + sw_failaction = fail_opt; + sw_dispatch = Switch_variant (Variant_runtime.matching_facts layout); + }) let combine_constructor loc arg ex_pat cstr partial ctx def (tag_lambda_list, total1, pats) = let is_extension = match cstr.cstr_kind with | Extension_constructor _ -> true - | Ordinary_constructor -> false + | Ordinary_constructor _ -> false in if is_extension then (* Special cases for extensions *) @@ -2086,15 +2169,11 @@ let combine_constructor loc arg ex_pat cstr partial ctx def (lambda1, jumps_union local_jumps total1) else (* Regular concrete type *) - let layout = - match cstr.cstr_layout with - | Some layout -> layout - | None -> assert false - in + let layout = Datarepr.constructor_variant cstr in let num_consts = Variant_runtime.num_constants layout and num_nonconsts = Variant_runtime.num_blocks layout in let ncases = List.length tag_lambda_list in - let sig_complete = ncases = Array.length layout in + let sig_complete = ncases = Variant_runtime.length layout in let fail_opt, fails, local_jumps = if sig_complete then (None, [], jumps_empty) else mk_failaction_pos partial pats ctx def @@ -2102,67 +2181,13 @@ let combine_constructor loc arg ex_pat cstr partial ctx def let tag_lambda_list = fails @ tag_lambda_list in let consts, nonconsts = split_cases tag_lambda_list in - let consts = sort_constructor_cases layout consts - and nonconsts = sort_constructor_cases layout nonconsts in - let lambda1 = - match (fail_opt, same_actions tag_lambda_list) with - | None, Some act -> act (* Identical actions, no failure *) - | _ -> ( - match (num_consts, num_nonconsts, consts, nonconsts) with - | 1, 1, [(_, act1)], [(_, act2)] - when cstr.cstr_name = "::" || cstr.cstr_name = "[]" - || Datarepr.constructor_has_optional_shape cstr -> - (* Typically, match on lists, will avoid isint primitive in that - case *) - let arg = - if Datarepr.constructor_has_optional_shape cstr then - Lprim (Pis_not_none, [arg], loc) - else - Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) - in - Lifthenelse (arg, act2, act1) - | 2, 0, _, [] when cstr.cstr_name = "true" || cstr.cstr_name = "false" - -> - let find_action name = - match - Ext_list.find_opt consts (fun (cstr, action) -> - if cstr.cstr_name = name then Some action else None) - with - | Some action -> action - | None -> assert false - in - let false_action = find_action "false" - and true_action = find_action "true" in - Lifthenelse (arg, true_action, false_action) - | _, _, _, _ -> - (* Emit a switch after constructor identity has been resolved to its - canonical runtime representation. *) - let consts = - List.map - (fun (cstr, action) -> - (constructor_switch_key layout cstr, action)) - consts - in - let nonconsts = - List.map - (fun (cstr, action) -> - (constructor_switch_key layout cstr, action)) - nonconsts - in - let sw = - { - sw_consts_full = List.length consts >= num_consts; - sw_consts = consts; - sw_blocks_full = List.length nonconsts >= num_nonconsts; - sw_blocks = nonconsts; - sw_failaction = fail_opt; - sw_dispatch = Switch_variant (Variant_runtime.dispatch layout); - } - in - let hs, sw = share_actions_sw sw in - let sw = reintroduce_fail sw in - hs (Lswitch (arg, sw, loc))) + let consts = sort_constructor_cases consts + and nonconsts = sort_constructor_cases nonconsts in + let plan = + make_constructor_matching_plan ~cstr ~layout ~fail_opt ~num_consts + ~num_nonconsts ~tag_lambda_list ~consts ~nonconsts in + let lambda1 = lower_constructor_matching_plan ~loc ~arg plan in (lambda1, jumps_union local_jumps total1) let make_test_sequence_variant_constant fail arg int_lambda_list = diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 05c74198b27..7533e6f6a0d 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -560,10 +560,10 @@ let all_record_args lbls = _, [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] ) when lbl_is_optional () -> ( - match cd.cstr_layout with - | None -> x - | Some layout -> ( - match Variant_runtime.constructor_by_name layout cd.cstr_name with + match cd.cstr_kind with + | Extension_constructor _ -> x + | Ordinary_constructor representation -> ( + match Variant_runtime.representation representation with | Block {block_type = Some block_type} when not (Ast_untagged_variants.block_type_can_be_undefined @@ -860,9 +860,11 @@ let row_of_pat pat = let full_match closing env = match env with | ({pat_desc = Tpat_construct (_, c, _)}, _) :: _ -> ( - match c.cstr_layout with - | None -> false (* extensions *) - | Some layout -> List.length env = Array.length layout) + match c.cstr_kind with + | Extension_constructor _ -> false + | Ordinary_constructor {variant} -> + List.length env + = Variant_runtime.length (Variant_runtime.get_layout variant)) | (({pat_desc = Tpat_variant _} as p), _) :: _ -> let fields = List.map @@ -906,7 +908,7 @@ let should_extend ext env = | [] -> assert false | (p, _) :: _ -> ( match p.pat_desc with - | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, _) -> + | Tpat_construct (_, {cstr_kind = Ordinary_constructor _}, _) -> let path = get_type_path p.pat_type p.pat_env in Path.same path ext | Tpat_construct (_, {cstr_kind = Extension_constructor _}, _) -> false @@ -982,7 +984,7 @@ let complete_constrs p seen_constrs = let build_other_constrs env p = match p.pat_desc with - | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, _) -> + | Tpat_construct (_, {cstr_kind = Ordinary_constructor _}, _) -> let get_constr = function | {pat_desc = Tpat_construct (_, c, _)} -> c | _ -> fatal_error "Parmatch.get_constr" @@ -2133,7 +2135,7 @@ let extendable_path path = let rec collect_paths_from_pat r p = match p.pat_desc with - | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, ps) -> + | Tpat_construct (_, {cstr_kind = Ordinary_constructor _}, ps) -> let path = get_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat (if extendable_path path then add_path path r else r) diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml index b6ca6f8d67b..3172318eef2 100644 --- a/compiler/ml/predef.ml +++ b/compiler/ml/predef.ml @@ -350,7 +350,7 @@ let common_initial_env add_type add_extension empty_env = cd_attributes = []; }; ]; - type_representation = Types.Transparent; + type_representation = Types.Unboxed; } and decl_promise = let tvar = newgenvar () in diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 9c28d547e3a..f9c55f3f233 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -896,7 +896,7 @@ and tree_of_type_decl id decl = otype_type = ty; otype_private = priv; otype_immediate = immediate; - otype_unboxed = decl.type_representation = Transparent || !untagged; + otype_unboxed = decl.type_representation = Unboxed || !untagged; otype_cstrs = constraints; } diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 86e4f6e542b..ef9fdd5e70e 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -269,7 +269,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | _ -> Use.empty in let use = - if Datarepr.constructor_is_transparent desc then fun x -> x else Use.guard + if Datarepr.constructor_is_unboxed desc then fun x -> x else Use.guard in Use.join access_constructor (use (list expression env exprs)) | Texp_variant (_, eo) -> Use.guard (option expression env eo) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 26db8023993..af584dc84a2 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -37,9 +37,7 @@ let transl_module = (* Number of payload-carrying constructors of the variant declaring [cstr]; part of the runtime representation of its blocks *) let num_nonconst_constructors (cstr : Types.constructor_description) = - match cstr.cstr_layout with - | Some layout -> Variant_runtime.num_blocks layout - | None -> assert false + Variant_runtime.num_blocks (Datarepr.constructor_variant cstr) (* Compile an exception/extension definition *) @@ -531,14 +529,14 @@ let transl_primitive_application loc prim env ty args = { exp_desc = Texp_construct - (_, {cstr_kind = Ordinary_constructor; cstr_args = []}, _); + (_, {cstr_kind = Ordinary_constructor _; cstr_args = []}, _); }; ] | [ { exp_desc = Texp_construct - (_, {cstr_kind = Ordinary_constructor; cstr_args = []}, _); + (_, {cstr_kind = Ordinary_constructor _; cstr_args = []}, _); }; _; ] @@ -769,7 +767,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | _ -> assert false else match cstr.cstr_kind with - | Ordinary_constructor when cstr.cstr_args = [] -> + | Ordinary_constructor _ when cstr.cstr_args = [] -> Lconst (Const_pointer (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none @@ -778,13 +776,13 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (match Datarepr.constructor_case cstr with | Constant tag -> tag | Block _ -> assert false))) - | Ordinary_constructor -> ( + | Ordinary_constructor _ -> ( let runtime = match Datarepr.constructor_case cstr with | Block {runtime} -> runtime | Constant _ -> assert false in - if Datarepr.constructor_is_transparent cstr then + if Datarepr.constructor_is_unboxed cstr then match ll with | [value] -> value | _ -> assert false @@ -1119,11 +1117,19 @@ and transl_record loc env fields repres opt_init_expr = | Record_float_unused -> assert false | Record_regular -> Lconst (Const_block (Lambda.blk_record fields mut, cl)) - | Record_inlined {name; num_nonconsts; attrs} -> + | Record_inlined {name; representation} -> + let runtime = + match Variant_runtime.representation representation with + | Block {runtime} -> runtime + | Constant _ -> assert false + in + let num_nonconsts = + Variant_runtime.num_blocks + (Variant_runtime.get_layout representation.variant) + in Lconst (Const_block - ( Lambda.blk_record_inlined fields name num_nonconsts - ~runtime:(Ast_untagged_variants.block_runtime ~name attrs) + ( Lambda.blk_record_inlined fields name num_nonconsts ~runtime mut, cl )) | Record_unboxed _ -> @@ -1137,11 +1143,19 @@ and transl_record loc env fields repres opt_init_expr = | Record_regular -> Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) | Record_float_unused -> assert false - | Record_inlined {name; num_nonconsts; attrs} -> + | Record_inlined {name; representation} -> + let runtime = + match Variant_runtime.representation representation with + | Block {runtime} -> runtime + | Constant _ -> assert false + in + let num_nonconsts = + Variant_runtime.num_blocks + (Variant_runtime.get_layout representation.variant) + in Lprim ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts - ~runtime:(Ast_untagged_variants.block_runtime ~name attrs) + (Lambda.blk_record_inlined fields name num_nonconsts ~runtime mut), ll, loc ) diff --git a/compiler/ml/typecore_record_rest.ml b/compiler/ml/typecore_record_rest.ml index b6b9ad92d47..aa7ed861483 100644 --- a/compiler/ml/typecore_record_rest.ml +++ b/compiler/ml/typecore_record_rest.ml @@ -108,14 +108,13 @@ let resolve_source_record ~env ~unify_pat_types ~loc ~record_ty let runtime_excluded_labels ~explicit_runtime_labels source_repr = match source_repr with - | Record_inlined {attrs; _} - when not (Ast_untagged_variants.process_untagged attrs) -> - let tag_name = - Ast_untagged_variants.process_tag_name attrs - |> Option.value ~default:"TAG" - in - if List.mem tag_name explicit_runtime_labels then explicit_runtime_labels - else tag_name :: explicit_runtime_labels + | Record_inlined {representation; _} -> ( + match Variant_runtime.representation representation with + | Block {runtime = {untagged = false; tag_name}} -> + let tag_name = Option.value tag_name ~default:"TAG" in + if List.mem tag_name explicit_runtime_labels then explicit_runtime_labels + else tag_name :: explicit_runtime_labels + | Constant _ | Block _ -> explicit_runtime_labels) | _ -> explicit_runtime_labels (* Type a record-rest pattern by resolving its annotation, checking that the diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index e7179c287f3..7c4a4214270 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -66,7 +66,7 @@ let get_representation_from_attributes sdecl = match (boxed, unboxed) with | true, true -> raise (Error (sdecl.ptype_loc, Boxed_and_unboxed)) | true, false | false, false -> Boxed - | false, true -> Transparent + | false, true -> Unboxed (* Enter all declared types in the environment as abstract types *) @@ -410,7 +410,7 @@ let transl_declaration ~type_record_as_object env sdecl id = | _ -> false in - (if raw_status = Transparent && not (check_untagged_variant ()) then + (if raw_status = Unboxed && not (check_untagged_variant ()) then match sdecl.ptype_kind with | Ptype_abstract -> raise (Error (sdecl.ptype_loc, Bad_unboxed_attribute "it is abstract")) @@ -440,7 +440,7 @@ let transl_declaration ~type_record_as_object env sdecl id = (* The type is not unboxable, mark it as boxed *) Boxed in - let unbox = representation = Transparent in + let unbox = representation = Unboxed in let tkind, kind, sdecl = match sdecl.ptype_kind with | Ptype_abstract -> (Ttype_abstract, Type_abstract, sdecl) @@ -594,7 +594,7 @@ let transl_declaration ~type_record_as_object env sdecl id = (* the canonical layout is computed once the whole recursive group is in the environment *) ( Ttype_variant tcstrs, - Type_variant (cstrs, Variant_runtime.dummy_layout), + Type_variant (cstrs, Variant_runtime.pending_layout ()), sdecl ) | Ptype_record lbls_ -> ( let optional_labels = @@ -1319,7 +1319,7 @@ let compute_immediacy env tdecl = | Type_variant ([{cd_args = Cstr_tuple [arg]; _}], _), _ | Type_variant ([{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _), _ | Type_record ([{ld_type = arg; _}], _), _ - when tdecl.type_representation = Transparent -> ( + when tdecl.type_representation = Unboxed -> ( match get_unboxed_type_representation env arg with | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) | None -> false) @@ -1582,7 +1582,7 @@ let transl_type_decl env rec_flag sdecl_list = List.map (fun (id, decl) -> match decl.type_kind with - | Type_variant (cstrs, _) -> + | Type_variant (cstrs, pending_layout) -> Ast_untagged_variants.check_tag_field_conflicts cstrs; let is_untagged_def = Ast_untagged_variants.has_untagged decl.type_attributes @@ -1591,7 +1591,8 @@ let transl_type_decl env rec_flag sdecl_list = Variant_layout.layout_from_type_variant ~is_untagged_def ~env:newenv cstrs in - (id, {decl with type_kind = Type_variant (cstrs, layout)}) + Variant_runtime.complete_layout pending_layout layout; + (id, decl) | Type_abstract | Type_record _ | Type_open -> (id, decl)) decls in diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 558a656cc5b..66a1e8c32d9 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -23,7 +23,7 @@ let scrape_ty env ty = match ty.desc with | Tconstr (p, _, _) -> ( match Env.find_type p env with - | {type_representation = Transparent; _} -> ( + | {type_representation = Unboxed; _} -> ( match Typedecl.get_unboxed_type_representation env ty with | None -> ty | Some ty2 -> ty2) @@ -67,26 +67,35 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = | [{cd_id = {name = "()"}; cd_args = Cstr_tuple []}] ), _ ) -> false (* conservative *) - | Type_variant (cdecls, _) -> - let untagged = - Ast_untagged_variants.has_untagged decl.type_attributes + | Type_variant (cdecls, layout_ref) -> + let layout = Variant_runtime.get_layout layout_ref in + let rec all_cases_cannot_contain_undefined position = function + | [] -> true + | cd :: rest -> + let case = Variant_runtime.constructor_at layout position in + let tag, payload_is_unboxed = + match case with + | Variant_runtime.Constant tag -> (tag, false) + | Variant_runtime.Block {runtime = {tag; untagged}} -> + (tag, untagged) + in + tag.tag_type <> Some Variant_runtime.Undefined + && ((not payload_is_unboxed) + || + match cd.cd_args with + | Cstr_tuple [t] -> + Ast_untagged_variants.type_is_builtin_object t + || type_cannot_contain_undefined t env + | Cstr_tuple [] -> true + | Cstr_tuple (_ :: _ :: _) -> + true (* Not actually possible for an unboxed payload. *) + | Cstr_record [{ld_type = t}] -> + Ast_untagged_variants.type_is_builtin_object t + || type_cannot_contain_undefined t env + | Cstr_record ([] | _ :: _ :: _) -> true) + && all_cases_cannot_contain_undefined (position + 1) rest in - Ext_list.for_all cdecls (fun cd -> - if Ast_untagged_variants.has_undefined_literal cd.cd_attributes then - false - else if untagged then - match cd.cd_args with - | Cstr_tuple [t] -> - Ast_untagged_variants.type_is_builtin_object t - || type_cannot_contain_undefined t env - | Cstr_tuple [] -> true - | Cstr_tuple (_ :: _ :: _) -> - true (* Not actually possible for untagged *) - | Cstr_record [{ld_type = t}] -> - Ast_untagged_variants.type_is_builtin_object t - || type_cannot_contain_undefined t env - | Cstr_record ([] | _ :: _ :: _) -> true - else true))) + all_cases_cannot_contain_undefined 0 cdecls)) | Ttuple _ | Tvariant _ | Tpackage _ | Tarrow _ -> true | Tfield _ | Tpoly _ | Tunivar _ | Tlink _ | Tsubst _ | Tnil | Tvar _ | Tobject _ -> diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml index f00b3082d77..7a544622f1f 100644 --- a/compiler/ml/types.ml +++ b/compiler/ml/types.ml @@ -143,8 +143,7 @@ and type_inlined_type = and type_kind = | Type_abstract | Type_record of label_declaration list * record_representation - | Type_variant of - constructor_declaration list * Variant_runtime.variant_layout + | Type_variant of constructor_declaration list * Variant_runtime.layout_ref | Type_open and record_representation = @@ -155,8 +154,7 @@ and record_representation = (* Inlined record *) { name: string; - num_nonconsts: int; - attrs: Parsetree.attributes; + representation: Variant_runtime.constructor_reference; } | Record_extension (* Inlined record under extension *) @@ -181,9 +179,10 @@ and constructor_arguments = | Cstr_tuple of type_expr list | Cstr_record of label_declaration list -and type_representation = Boxed | Transparent +and type_representation = Boxed | Unboxed (* Single-payload @unboxed type: the payload is the whole runtime - value. Untagged unions are tracked by their attributes, not here. *) + value. Multi-constructor unboxed variants are tracked by their layout, + not here. *) type extension_constructor = { ext_type_path: Path.t; @@ -251,9 +250,6 @@ type constructor_description = { cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_kind: constructor_kind; - cstr_layout: Variant_runtime.variant_layout option; - (* Runtime layout of the declaring variant; None for extension - constructors *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; @@ -262,9 +258,10 @@ type constructor_description = { } and constructor_kind = - | Ordinary_constructor - (* Constructor introduced by a variant type declaration; identified - within its variant by [cstr_name] *) + | Ordinary_constructor of Variant_runtime.constructor_reference + (* Constructor introduced by a variant type declaration. This stable + reference addresses its runtime representation directly; the shared + variant value also supplies declaration-level matching facts. *) | Extension_constructor of Path.t (* Extension constructor, identified by its own path since extension constructors can be rebound *) @@ -276,9 +273,10 @@ and constructor_kind = general-purpose identity test across unrelated types. *) let same_constructor c1 c2 = match (c1.cstr_kind, c2.cstr_kind) with - | Ordinary_constructor, Ordinary_constructor -> c1.cstr_name = c2.cstr_name + | Ordinary_constructor _, Ordinary_constructor _ -> + c1.cstr_name = c2.cstr_name | Extension_constructor p1, Extension_constructor p2 -> Path.same p1 p2 - | (Ordinary_constructor | Extension_constructor _), _ -> false + | (Ordinary_constructor _ | Extension_constructor _), _ -> false let may_equal_constr c1 c2 = match (c1.cstr_kind, c2.cstr_kind) with @@ -306,9 +304,9 @@ let same_record_representation x y = match x with | Record_regular -> y = Record_regular | Record_float_unused -> y = Record_float_unused - | Record_inlined {name; num_nonconsts} -> ( + | Record_inlined {name} -> ( match y with - | Record_inlined y -> name = y.name && num_nonconsts = y.num_nonconsts + | Record_inlined y -> name = y.name | _ -> false) | Record_extension -> y = Record_extension | Record_unboxed x -> ( diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli index 07ef083c90d..df6a8bae274 100644 --- a/compiler/ml/types.mli +++ b/compiler/ml/types.mli @@ -249,8 +249,7 @@ and type_inlined_type = and type_kind = | Type_abstract | Type_record of label_declaration list * record_representation - | Type_variant of - constructor_declaration list * Variant_runtime.variant_layout + | Type_variant of constructor_declaration list * Variant_runtime.layout_ref | Type_open and record_representation = @@ -261,8 +260,7 @@ and record_representation = (* Inlined record *) { name: string; - num_nonconsts: int; - attrs: Parsetree.attributes; + representation: Variant_runtime.constructor_reference; } | Record_extension (* Inlined record under extension *) @@ -287,9 +285,10 @@ and constructor_arguments = | Cstr_tuple of type_expr list | Cstr_record of label_declaration list -and type_representation = Boxed | Transparent +and type_representation = Boxed | Unboxed (* Single-payload @unboxed type: the payload is the whole runtime - value. Untagged unions are tracked by their attributes, not here. *) + value. Multi-constructor unboxed variants are tracked by their layout, + not here. *) type extension_constructor = { ext_type_path: Path.t; @@ -355,9 +354,6 @@ type constructor_description = { cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_kind: constructor_kind; - cstr_layout: Variant_runtime.variant_layout option; - (* Runtime layout of the declaring variant; None for extension - constructors *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; @@ -366,9 +362,10 @@ type constructor_description = { } and constructor_kind = - | Ordinary_constructor - (* Constructor introduced by a variant type declaration; identified - within its variant by [cstr_name] *) + | Ordinary_constructor of Variant_runtime.constructor_reference + (* Constructor introduced by a variant type declaration. This stable + reference addresses its runtime representation directly; the shared + variant value also supplies declaration-level matching facts. *) | Extension_constructor of Path.t (* Extension constructor, identified by its own path since extension constructors can be rebound *) diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 93b02d834ad..2ca68466862 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -60,8 +60,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : | true, _ -> None (* TODO: add restrictions here *) let layout_from_type_variant ?(is_untagged_def = false) ~env - (cstrs : Types.constructor_declaration list) : - Variant_runtime.variant_layout = + (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = { runtime = block_runtime ~name:(Ident.name cstr.cd_id) cstr.cd_attributes; @@ -89,4 +88,4 @@ let layout_from_type_variant ?(is_untagged_def = false) ~env Array.of_list (List.map (fun (_, constructor) -> constructor) located_constructors) in - constructors + Variant_runtime.make_layout constructors diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index ee8085349c4..19532389de3 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -93,53 +93,75 @@ type block = {runtime: block_runtime; block_type: block_type option} type constructor_case = Constant of tag | Block of block -type variant_dispatch = { +type matching_facts = { tag_name: string option; + (** Custom object field containing constructor tags. [None] means the + standard [TAG] field. *) block_types: block_type list; + (** Runtime shapes of constructors represented directly by their + payload. Tagged object constructors do not appear here. *) literal_tags: tag_type list; + (** Runtime values of all nullary constructors. *) has_null: bool; has_undefined: bool; has_other_literal: bool; } -(** The whole-variant information needed to choose a JavaScript dispatch - strategy. Constructor identity is carried by each switch arm instead. *) - -type variant_layout = constructor_case array -(** Canonical runtime layout in source-constructor order. *) - -let case_name = function - | Constant {name} -> name - | Block {runtime = {tag = {name}}} -> name - -let constructor_position (layout : variant_layout) name = - let rec find i = - if i >= Array.length layout then - invalid_arg ("Variant_runtime.constructor_position: " ^ name) - else if case_name layout.(i) = name then i - else find (i + 1) - in - find 0 +(** Declaration-level facts needed when lowering a constructor match. This is + not an occurrence-specific matching plan: it contains no arms, actions, + default, guard, or exhaustiveness information. *) + +type layout = { + constructors: constructor_case array; + matching_facts: matching_facts; +} +(** Completed, immutable runtime representation of a variant declaration. + Constructor cases are kept in source order and [matching_facts] is computed + once from those cases. *) + +type layout_state = Pending | Complete of layout + +type layout_ref = layout_state ref +(** Stable forward reference used while translating a recursive declaration. + It is completed exactly once, after the whole recursive group is available + in the environment. *) + +type constructor_reference = {variant: layout_ref; position: int} +(** Stable, constant-time reference from a constructor description to its + entry in the declaring variant. *) -let constructor_by_name (layout : variant_layout) name = - layout.(constructor_position layout name) +let get_layout layout_ref = + match !layout_ref with + | Complete layout -> layout + | Pending -> + failwith + "Variant_runtime.get_layout: layout accessed before type declaration was \ + complete" -let num_constants (layout : variant_layout) = +let constructor_at (layout : layout) position = layout.constructors.(position) + +let representation ({variant; position} : constructor_reference) = + constructor_at (get_layout variant) position + +let length (layout : layout) = Array.length layout.constructors + +let num_constants (layout : layout) = Array.fold_left (fun n case -> match case with | Constant _ -> n + 1 | Block _ -> n) - 0 layout + 0 layout.constructors -let num_blocks (layout : variant_layout) = +let num_blocks (layout : layout) = Array.fold_left (fun n case -> match case with | Block _ -> n + 1 | Constant _ -> n) - 0 layout + 0 layout.constructors -let dispatch (constructors : variant_layout) : variant_dispatch = +let compute_matching_facts (constructors : constructor_case array) : + matching_facts = let tag_name = ref None in let block_types = ref [] in let literal_tags = ref [] in @@ -175,15 +197,23 @@ let dispatch (constructors : variant_layout) : variant_dispatch = has_other_literal = !has_other_literal; } -(* Placeholder used while a recursive declaration group is being typed; - [Typedecl] replaces it with the computed layout once the group is in the - environment *) -let dummy_layout : variant_layout = [||] +let make_layout constructors = + {constructors; matching_facts = compute_matching_facts constructors} + +let matching_facts layout = layout.matching_facts + +let pending_layout () = ref Pending + +let complete_layout layout_ref layout = + match !layout_ref with + | Pending -> layout_ref := Complete layout + | Complete _ -> + failwith + "Variant_runtime.complete_layout: type declaration layout completed twice" (* Layout of a variant that carries no representation attributes; used for predefined types, whose declarations are built by hand *) -let plain_layout (cases : (string * bool (* has payload *)) list) : - variant_layout = +let plain_layout (cases : (string * bool (* has payload *)) list) : layout_ref = let case (name, has_payload) = if has_payload then Block @@ -194,4 +224,4 @@ let plain_layout (cases : (string * bool (* has payload *)) list) : } else Constant {name; tag_type = None} in - Array.of_list (List.map case cases) + ref (Complete (make_layout (Array.of_list (List.map case cases)))) diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli new file mode 100644 index 00000000000..defc6c97dcc --- /dev/null +++ b/compiler/ml/variant_runtime.mli @@ -0,0 +1,80 @@ +module Instance : sig + type t = + | Array + | ArrayBuffer + | BigInt64Array + | BigUint64Array + | Blob + | DataView + | Date + | File + | Float32Array + | Float64Array + | Int16Array + | Int32Array + | Int8Array + | Promise + | RegExp + | Uint16Array + | Uint32Array + | Uint8Array + | Uint8ClampedArray + | Set + | Map + | WeakSet + | WeakMap + + val to_string : t -> string +end + +type block_type = + | IntType + | StringType + | FloatType + | BigintType + | BooleanType + | InstanceType of Instance.t + | FunctionType + | ObjectType + | UnknownType + +type tag_type = + | String of string + | Int of int + | Float of string + | BigInt of string + | Bool of bool + | Null + | Undefined + | Untagged of block_type + +type tag = {name: string; tag_type: tag_type option} +type block_runtime = {tag: tag; tag_name: string option; untagged: bool} +type block = {runtime: block_runtime; block_type: block_type option} +type constructor_case = Constant of tag | Block of block + +type matching_facts = { + tag_name: string option; + block_types: block_type list; + literal_tags: tag_type list; + has_null: bool; + has_undefined: bool; + has_other_literal: bool; +} + +type layout +type layout_ref + +type constructor_reference = {variant: layout_ref; position: int} + +val make_layout : constructor_case array -> layout +val pending_layout : unit -> layout_ref +val complete_layout : layout_ref -> layout -> unit +val get_layout : layout_ref -> layout +val matching_facts : layout -> matching_facts +val constructor_at : layout -> int -> constructor_case +val representation : constructor_reference -> constructor_case +val length : layout -> int +val num_constants : layout -> int +val num_blocks : layout -> int +val plain_layout : (string * bool) list -> layout_ref From af4965863b58c321ad44a31d879e27de592b8c61 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 25 Aug 2026 12:48:10 +0200 Subject: [PATCH 7/7] Consume variant representation annotations into typed layouts Variant representation annotations are syntax-level inputs, but their meaning is needed throughout type inclusion, coercion, printing, diagnostics, and GenType. Previously those consumers independently re-read attributes from typed declarations and constructors, leaving both the annotations and their interpreted representation live in later compiler phases. Build the canonical declaration configuration together with the variant layout after the recursive declaration group has entered the environment. Retain the declared unboxing bit and custom tag field even for shapes, such as nullary-only variants, from which those choices cannot be recovered by inspecting constructor blocks. Constructor tags and unboxed payload facts remain indexed by source position in the same completed layout. Migrate Ctype coercions, inclusion checks, Printtyp, error suggestions, and GenType to consume the typed layout and the existing type/record representations instead of parsing attributes. This also makes GenType distinguish nominal variants from polymorphic variants explicitly: nominal cases use canonical constructor tags, while polymorphic variants continue to interpret their own row-field annotations. Keep attribute interpretation only at the typing boundary that creates the layout and in the pre-typing variant-spread compatibility check, where no completed target layout exists yet. Preserve legacy single-payload unboxing through Types.type_representation and combine it with declaration-level layout configuration when an effective runtime configuration is required. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + .../gentype/translate_signature_from_types.ml | 21 +++- .../gentype/translate_type_declarations.ml | 90 ++++++++++----- compiler/ml/ctype.ml | 81 ++++++++------ compiler/ml/error_message_utils.ml | 16 +-- compiler/ml/includecore.ml | 58 ++++++---- compiler/ml/printtyp.ml | 43 ++++--- compiler/ml/typedecl.ml | 10 +- compiler/ml/variant_coercion.ml | 105 +++++++++--------- compiler/ml/variant_layout.ml | 6 +- compiler/ml/variant_runtime.ml | 39 +++++-- compiler/ml/variant_runtime.mli | 15 ++- 12 files changed, 306 insertions(+), 179 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index df6c215cb6b..7298a06ad7e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -50,6 +50,7 @@ #### :house: Internal +- Give nominal variants one canonical runtime layout: compute their JavaScript representation once after typing each declaration, replace positional constructor tags with semantic runtime descriptors, and make construction, matching, coercion, printing, diagnostics, and GenType consume the stored representation instead of reinterpreting annotations. Pattern matching keeps occurrence-specific plans local without adding another Lambda or Lam expression form. https://github.com/rescript-lang/rescript/pull/8579 - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 - Make locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 diff --git a/compiler/gentype/translate_signature_from_types.ml b/compiler/gentype/translate_signature_from_types.ml index 64d37058abf..94236756c2e 100644 --- a/compiler/gentype/translate_signature_from_types.ml +++ b/compiler/gentype/translate_signature_from_types.ml @@ -3,7 +3,14 @@ open Gentype_common (** Like translateTypeDeclaration but from Types not Typedtree *) let translate_type_declaration_from_types ~config ~output_file_relative ~resolver ~type_env ~id - ({type_attributes; type_kind; type_loc; type_manifest; type_params} : + ({ + type_attributes; + type_kind; + type_loc; + type_manifest; + type_params; + type_representation; + } : Types.type_declaration) : Code_item.type_declaration list = type_env |> Type_env.new_type ~name:(id |> Ident.name); let type_name = Ident.name id in @@ -12,13 +19,17 @@ let translate_type_declaration_from_types ~config ~output_file_relative Log_.item "Translate Types.type_declaration %s\n" type_name; let declaration_kind = match type_kind with - | Type_record (label_declarations, _) -> - Translate_type_declarations.RecordDeclarationFromTypes label_declarations - | Type_variant (constructor_declarations, _) + | Type_record (label_declarations, representation) -> + Translate_type_declarations.RecordDeclarationFromTypes + (label_declarations, representation) + | Type_variant (constructor_declarations, layout_ref) when not (Translate_type_declarations.has_some_gadt_leaf constructor_declarations) -> - VariantDeclarationFromTypes constructor_declarations + VariantDeclarationFromTypes + ( constructor_declarations, + Variant_runtime.get_layout layout_ref, + type_representation ) | Type_abstract -> GeneralDeclarationFromTypes type_manifest | _ -> NoDeclaration in diff --git a/compiler/gentype/translate_type_declarations.ml b/compiler/gentype/translate_type_declarations.ml index 1167bca692a..561816b0802 100644 --- a/compiler/gentype/translate_type_declarations.ml +++ b/compiler/gentype/translate_type_declarations.ml @@ -1,11 +1,15 @@ open Gentype_common type declaration_kind = - | RecordDeclarationFromTypes of Types.label_declaration list + | RecordDeclarationFromTypes of + Types.label_declaration list * Types.record_representation | GeneralDeclaration of Typedtree.core_type option | GeneralDeclarationFromTypes of Types.type_expr option (** As the above, but from Types not Typedtree *) - | VariantDeclarationFromTypes of Types.constructor_declaration list + | VariantDeclarationFromTypes of + Types.constructor_declaration list + * Variant_runtime.layout + * Types.type_representation | NoDeclaration let create_export_type_from_type_declaration ~annotation ~loc ~name_as ~opaque @@ -20,7 +24,7 @@ let create_export_type_from_type_declaration ~annotation ~loc ~name_as ~opaque annotation; } -let create_case (label, attributes) ~poly = +let create_polyvariant_case (label, attributes) = { label_js = (match @@ -32,10 +36,20 @@ let create_case (label, attributes) ~poly = | Some (_, FloatPayload s) -> FloatLabel s | Some (_, IntPayload i) -> IntLabel i | Some (_, StringPayload as_label) -> StringLabel as_label - | _ -> - if poly && is_number label then IntLabel label else StringLabel label); + | _ -> if is_number label then IntLabel label else StringLabel label); } +let create_variant_case label = function + | Some (Variant_runtime.String label) -> {label_js = StringLabel label} + | Some (Variant_runtime.Int label) -> + {label_js = IntLabel (string_of_int label)} + | Some (Variant_runtime.Float label) -> {label_js = FloatLabel label} + | Some (Variant_runtime.BigInt label) -> {label_js = IntLabel label} + | Some (Variant_runtime.Bool label) -> {label_js = BoolLabel label} + | Some Variant_runtime.Null -> {label_js = NullLabel} + | Some Variant_runtime.Undefined -> {label_js = UndefinedLabel} + | Some (Variant_runtime.Untagged _) | None -> {label_js = StringLabel label} + (** * Rename record fields. * If @genType.as is used, perform renaming conversion. @@ -65,10 +79,6 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver let import_string_opt, name_as = type_attributes |> Annotation.get_attribute_import_renaming in - let unboxed_annotation = - type_attributes |> Annotation.has_attribute Annotation.tag_is_unboxed - in - let tag_annotation = type_attributes |> Annotation.get_tag in let return_type_declaration (type_declaration : Code_item.type_declaration) = match opaque = Some true with | true -> [{type_declaration with import_types = []}] @@ -88,7 +98,8 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in {Code_item.import_types; export_from_type_declaration} in - let translate_label_declarations ?(inline = false) label_declarations = + let translate_label_declarations ?(inline = false) ?(unboxed = false) + label_declarations = let field_translations = label_declarations |> List.map @@ -137,7 +148,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in let type_ = match fields with - | [field] when unboxed_annotation -> field.type_ + | [field] when unboxed -> field.type_ | _ -> Object ((if inline then Inline else Closed), fields) in {Translate_type_expr_from_types.dependencies; type_} @@ -201,7 +212,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver row_fields |> Translate_core_type.process_variant in let no_payloads = - row_fields_variants.no_payloads |> List.map (create_case ~poly:true) + row_fields_variants.no_payloads |> List.map create_polyvariant_case in let payloads = if @@ -211,7 +222,7 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver (List.combine variant.payloads row_fields_variants.payloads [@doesNotRaise]) |> List.map (fun (payload, (label, attributes, _)) -> - let case = (label, attributes) |> create_case ~poly:true in + let case = create_polyvariant_case (label, attributes) in {payload with case}) else variant.payloads in @@ -221,9 +232,15 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver in {translation with type_} |> handle_general_declaration |> return_type_declaration - | RecordDeclarationFromTypes label_declarations, None -> + | RecordDeclarationFromTypes (label_declarations, representation), None -> + let unboxed = + match representation with + | Record_unboxed _ -> true + | Record_regular | Record_inlined _ | Record_extension -> false + | Record_float_unused -> assert false + in let {Translate_type_expr_from_types.dependencies; type_} = - label_declarations |> translate_label_declarations + label_declarations |> translate_label_declarations ~unboxed in let import_types = dependencies @@ -238,13 +255,16 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver ~name_as ~opaque ~type_ ~type_env ~type_vars; } |> return_type_declaration - | VariantDeclarationFromTypes constructor_declarations, None -> + | ( VariantDeclarationFromTypes + (constructor_declarations, layout, type_representation), + None ) -> + let {Variant_runtime.tag_name} = Variant_runtime.matching_facts layout in let variants = constructor_declarations - |> List.map (fun constructor_declaration -> + |> List.mapi (fun position constructor_declaration -> let constructor_args = constructor_declaration.Types.cd_args in - let attributes = constructor_declaration.cd_attributes in let name = constructor_declaration.cd_id |> Ident.name in + let tag = Variant_runtime.constructor_tag layout position in let args_translation = match constructor_args with | Cstr_tuple type_exprs -> @@ -254,7 +274,11 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver | Cstr_record label_declarations -> [ label_declarations - |> translate_label_declarations ~inline:true; + |> translate_label_declarations ~inline:true + ~unboxed: + (type_representation = Unboxed + || Variant_runtime.constructor_is_untagged layout + position); ] in let arg_types = @@ -269,29 +293,34 @@ let traslate_declaration_kind ~config ~loc ~output_file_relative ~resolver |> Translation.translate_dependencies ~config ~output_file_relative ~resolver in - (name, attributes, arg_types, import_types)) + (name, tag, arg_types, import_types)) in let variants_no_payload, variants_with_payload = variants |> List.partition (fun (_, _, arg_types, _) -> arg_types = []) in let no_payloads = variants_no_payload - |> List.map (fun (name, attributes, _argTypes, _importTypes) -> - (name, attributes) |> create_case ~poly:false) + |> List.map (fun (name, tag, _argTypes, _importTypes) -> + create_variant_case name tag) in let payloads = variants_with_payload - |> List.map (fun (name, attributes, arg_types, _importTypes) -> + |> List.map (fun (name, tag, arg_types, _importTypes) -> let type_ = match arg_types with | [type_] -> type_ | _ -> Tuple arg_types in - {case = (name, attributes) |> create_case ~poly:false; t = type_}) + {case = create_variant_case name tag; t = type_}) in let variant_typ = + let unboxed = + match type_representation with + | Unboxed -> true + | Boxed -> (Variant_runtime.configuration layout).unboxed + in create_variant ~inherits:[] ~no_payloads ~payloads ~polymorphic:false - ~tag:tag_annotation ~unboxed:unboxed_annotation + ~tag:tag_name ~unboxed in let resolved_type_name = type_name |> sanitize_type_name |> Type_env.add_module_path ~type_env @@ -339,10 +368,13 @@ let translate_type_declaration ~config ~output_file_relative ~resolver ~type_env in let declaration_kind = match typ_type.type_kind with - | Type_record (label_declarations, _) -> - RecordDeclarationFromTypes label_declarations - | Type_variant (constructor_declarations, _) -> - VariantDeclarationFromTypes constructor_declarations + | Type_record (label_declarations, representation) -> + RecordDeclarationFromTypes (label_declarations, representation) + | Type_variant (constructor_declarations, layout_ref) -> + VariantDeclarationFromTypes + ( constructor_declarations, + Variant_runtime.get_layout layout_ref, + typ_type.type_representation ) | Type_abstract -> GeneralDeclaration typ_manifest | _ -> NoDeclaration in diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index 0ace5e8ddf2..4f5eeb0712d 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -3510,7 +3510,7 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with - | Some (p, _, false) -> + | Some (p, _, _, false) -> (* Not @unboxed *) ( trace, t1, @@ -3520,7 +3520,7 @@ let rec subtype_rec env trace t1 t2 cstrs = (Coercion_target_variant_not_unboxed {variant_name = p; primitive = path}) ) :: cstrs - | Some (p, constructors, true) -> + | Some (p, constructors, _, true) -> if Variant_coercion.variant_has_case_covering_type constructors ~path_is_same_fn:(fun p -> Path.same p path) @@ -3548,12 +3548,12 @@ let rec subtype_rec env trace t1 t2 cstrs = Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with - | Some (p, constructors, unboxed) -> + | Some (p, constructors, layout, unboxed) -> let runtime_representation_issues = constructors |> Variant_coercion .variant_has_same_runtime_representation_as_target - ~target_path:path ~unboxed + ~target_path:path ~unboxed ~layout in if List.length runtime_representation_issues <> 0 then ( trace, @@ -3574,14 +3574,29 @@ let rec subtype_rec env trace t1 t2 cstrs = with | ( ( p1, _, - {type_kind = Type_variant (c1, _); type_attributes = t1attrs} ), + { + type_kind = Type_variant (c1, layout_ref1); + type_representation = type_representation1; + } ), ( p2, _, - {type_kind = Type_variant (c2, _); type_attributes = t2attrs} ) ) - -> ( + { + type_kind = Type_variant (c2, layout_ref2); + type_representation = type_representation2; + } ) ) -> ( + let layout1 = Variant_runtime.get_layout layout_ref1 in + let layout2 = Variant_runtime.get_layout layout_ref2 in + let configuration1 = + Variant_coercion.runtime_configuration + ~type_representation:type_representation1 ~layout:layout1 + in + let configuration2 = + Variant_coercion.runtime_configuration + ~type_representation:type_representation2 ~layout:layout2 + in match - Variant_coercion.variant_configuration_can_be_coerced t1attrs - t2attrs + Variant_coercion.variant_configuration_can_be_coerced configuration1 + configuration2 with | Error issue -> ( trace, @@ -3623,28 +3638,26 @@ let rec subtype_rec env trace t1 t2 cstrs = else let constructor_map = Hashtbl.create c1_len in c2 - |> List.iter (fun (c : Types.constructor_declaration) -> - Hashtbl.add constructor_map (Ident.name c.cd_id) c); + |> List.iteri (fun position (c : Types.constructor_declaration) -> + Hashtbl.add constructor_map (Ident.name c.cd_id) + (c, position)); let field_subtype_violations = c1 - |> List.filter_map (fun (c : Types.constructor_declaration) -> + |> List.mapi + (fun position1 (c : Types.constructor_declaration) -> match ( c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id) ) with - | ( { - Types.cd_args = Cstr_record fields1; - cd_attributes = c1_attributes; - }, + | ( {Types.cd_args = Cstr_record fields1}, Some - { - Types.cd_args = Cstr_record fields2; - cd_attributes = c2_attributes; - } ) -> + ({Types.cd_args = Cstr_record fields2}, position2) + ) -> if Variant_coercion.variant_representation_matches - c1_attributes c2_attributes + (Variant_runtime.constructor_tag layout1 position1) + (Variant_runtime.constructor_tag layout2 position2) then let violations, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 @@ -3665,18 +3678,13 @@ let rec subtype_rec env trace t1 t2 cstrs = else Some [ (* TODO(subtype-errors) Variant constructor representation mismatch*) ] - | ( { - Types.cd_args = Cstr_tuple tl1; - cd_attributes = c1_attributes; - }, - Some - { - Types.cd_args = Cstr_tuple tl2; - cd_attributes = c2_attributes; - } ) -> + | ( {Types.cd_args = Cstr_tuple tl1}, + Some ({Types.cd_args = Cstr_tuple tl2}, position2) ) + -> if Variant_coercion.variant_representation_matches - c1_attributes c2_attributes + (Variant_runtime.constructor_tag layout1 position1) + (Variant_runtime.constructor_tag layout2 position2) then try let lst = subtype_list env trace tl1 tl2 cstrs in @@ -3692,6 +3700,7 @@ let rec subtype_rec env trace t1 t2 cstrs = [ (* TODO(subtype-errors) Variant constructor tuple mismatch *) ] | _ -> Some [ (* TODO(subtype-errors) Variant other issue *) ]) + |> List.filter_map Fun.id in if field_subtype_violations = [] then cstrs else (trace, t1, t2, !univar_pairs, None) :: cstrs) @@ -3764,12 +3773,16 @@ let rec subtype_rec env trace t1 t2 cstrs = | ( _, _, { - type_kind = Type_variant (variant_constructors, _); - type_attributes; + type_kind = Type_variant (variant_constructors, layout_ref); + type_representation; } ) -> ( + let layout = Variant_runtime.get_layout layout_ref in + let {Variant_runtime.unboxed} = + Variant_coercion.runtime_configuration ~type_representation ~layout + in match Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields - ~variant_constructors ~type_attributes + ~variant_constructors ~layout ~unboxed with | Ok _ -> cstrs | Error _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index c9bee3e5f86..74991693974 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -217,8 +217,9 @@ let is_jsx_component_type ~env ty = let get_variant_constructors ~(extract_concrete_typedecl : extract_concrete_typedecl) ~env ty = match extract_concrete_typedecl env ty with - | _, _, {Types.type_kind = Type_variant (constructors, _); _} -> constructors - | _ -> [] + | _, _, {Types.type_kind = Type_variant (constructors, layout_ref); _} -> + Some (constructors, Variant_runtime.get_layout layout_ref) + | _ -> None let extract_string_constant text = match !Parser.parse_source text with @@ -685,16 +686,16 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf let target_expr_text = Parser.extract_text_at_loc loc in match extract_string_constant target_expr_text with | Some string_value -> ( - let constructors = - get_variant_constructors ~extract_concrete_typedecl ~env t2 + let constructors, layout = + Option.get (get_variant_constructors ~extract_concrete_typedecl ~env t2) in (* Extract runtime representations from constructor declarations *) let constructor_mappings = - List.filter_map - (fun (cd : Types.constructor_declaration) -> + List.mapi + (fun position (cd : Types.constructor_declaration) -> let constructor_name = Ident.name cd.cd_id in let runtime_repr = - match Ast_untagged_variants.process_tag_type cd.cd_attributes with + match Variant_runtime.constructor_tag layout position with | Some (String s) -> Some s (* @as("string_value") *) | Some _ -> None (* @as with non-string values *) | None -> Some constructor_name (* No @as, use constructor name *) @@ -703,6 +704,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf | Some repr -> Some (repr, constructor_name) | None -> None) constructors + |> List.filter_map Fun.id in let matching_constructor = List.find_opt diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml index e41a2122836..130c3754db0 100644 --- a/compiler/ml/includecore.ml +++ b/compiler/ml/includecore.ml @@ -226,7 +226,7 @@ let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 = compare_records env ~loc params1 params2 0 l1 l2 | _ -> [Field_type cstr] -and compare_variants ~loc env params1 params2 n +and compare_variants ~loc env params1 params2 ~layout1 ~layout2 n (cstrs1 : Types.constructor_declaration list) (cstrs2 : Types.constructor_declaration list) = match (cstrs1, cstrs2) with @@ -257,18 +257,16 @@ and compare_variants ~loc env params1 params2 n else match Ast_untagged_variants.is_nullary_variant cd1.cd_args with | true -> - let tag_type1 = - Ast_untagged_variants.process_tag_type cd1.cd_attributes - in - let tag_type2 = - Ast_untagged_variants.process_tag_type cd2.cd_attributes - in + let tag_type1 = Variant_runtime.constructor_tag layout1 (n - 1) in + let tag_type2 = Variant_runtime.constructor_tag layout2 (n - 1) in if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id] else [] | false -> r in if r <> [] then r - else compare_variants ~loc env params1 params2 (n + 1) rem1 rem2) + else + compare_variants ~loc env params1 params2 ~layout1 ~layout2 (n + 1) rem1 + rem2) and compare_records ~loc env params1_ params2_ n_ (labels1_ : Types.label_declaration list) @@ -342,17 +340,19 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = if err <> [] then err else let err = - let untagged1 = - Ast_untagged_variants.process_untagged decl1.type_attributes - in - let untagged2 = - Ast_untagged_variants.process_untagged decl2.type_attributes + let is_unboxed decl = + match decl.type_kind with + | Type_variant (_, layout_ref) -> + let layout = Variant_runtime.get_layout layout_ref in + let {Variant_runtime.unboxed} = + Variant_coercion.runtime_configuration + ~type_representation:decl.type_representation ~layout + in + unboxed + | Type_abstract | Type_record _ | Type_open -> + decl.type_representation = Unboxed in - match - ( decl2.type_kind, - decl1.type_representation = Unboxed || untagged1, - decl2.type_representation = Unboxed || untagged2 ) - with + match (decl2.type_kind, is_unboxed decl1, is_unboxed decl2) with | Type_abstract, _, _ -> [] | _, true, false -> [Unboxed_representation false] | _, false, true -> [Unboxed_representation true] @@ -361,12 +361,19 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = if err <> [] then err else let err = - let tag1 = - Ast_untagged_variants.process_tag_name decl1.type_attributes - in - let tag2 = - Ast_untagged_variants.process_tag_name decl2.type_attributes + let tag_name decl = + match decl.type_kind with + | Type_variant (_, layout_ref) -> + let layout = Variant_runtime.get_layout layout_ref in + let configuration : Variant_runtime.configuration = + Variant_coercion.runtime_configuration + ~type_representation:decl.type_representation ~layout + in + configuration.tag_name + | Type_abstract | Type_record _ | Type_open -> None in + let tag1 = tag_name decl1 in + let tag2 = tag_name decl2 in if tag1 <> tag2 then [Tag_name] else err in if err <> [] then err @@ -374,7 +381,8 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = let err = match (decl1.type_kind, decl2.type_kind) with | _, Type_abstract -> [] - | Type_variant (cstrs1, _), Type_variant (cstrs2, _) -> + | ( Type_variant (cstrs1, layout_ref1), + Type_variant (cstrs2, layout_ref2) ) -> let mark cstrs usage name decl = List.iter (fun c -> @@ -390,6 +398,8 @@ let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = mark cstrs1 usage name decl1; if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; compare_variants ~loc env decl1.type_params decl2.type_params 1 + ~layout1:(Variant_runtime.get_layout layout_ref1) + ~layout2:(Variant_runtime.get_layout layout_ref2) cstrs1 cstrs2 | Type_record (labels1, rep1), Type_record (labels2, rep2) -> let err = diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index f9c55f3f233..e203e03a85c 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -870,24 +870,39 @@ and tree_of_type_decl id decl = in let name, args = type_defined decl in let constraints = tree_of_constraints ~printing_context params in - let untagged = ref false in - let ty, priv = + let ty, priv, unboxed = match decl.type_kind with | Type_abstract -> ( match ty_manifest with - | None -> (Otyp_abstract, Public) - | Some ty -> (tree_of_typexp ~printing_context false ty, decl.type_private) - ) - | Type_variant (cstrs, _) -> - untagged := Ast_untagged_variants.process_untagged decl.type_attributes; + | None -> (Otyp_abstract, Public, decl.type_representation = Unboxed) + | Some ty -> + ( tree_of_typexp ~printing_context false ty, + decl.type_private, + decl.type_representation = Unboxed )) + | Type_variant (cstrs, layout_ref) -> + let layout = Variant_runtime.get_layout layout_ref in + let {Variant_runtime.unboxed} = + Variant_coercion.runtime_configuration + ~type_representation:decl.type_representation ~layout + in ( tree_of_manifest - (Otyp_sum (List.map (tree_of_constructor ~printing_context) cstrs)), - decl.type_private ) + (Otyp_sum + (List.mapi + (fun position constructor -> + tree_of_constructor ~printing_context ~layout ~position + constructor) + cstrs)), + decl.type_private, + unboxed ) | Type_record (lbls, _rep) -> ( tree_of_manifest (Otyp_record (List.map (tree_of_label ~printing_context) lbls)), - decl.type_private ) - | Type_open -> (tree_of_manifest Otyp_open, decl.type_private) + decl.type_private, + decl.type_representation = Unboxed ) + | Type_open -> + ( tree_of_manifest Otyp_open, + decl.type_private, + decl.type_representation = Unboxed ) in let immediate = Builtin_attributes.immediate decl.type_attributes in { @@ -896,7 +911,7 @@ and tree_of_type_decl id decl = otype_type = ty; otype_private = priv; otype_immediate = immediate; - otype_unboxed = decl.type_representation = Unboxed || !untagged; + otype_unboxed = unboxed; otype_cstrs = constraints; } @@ -904,13 +919,13 @@ and tree_of_constructor_arguments ?printing_context = function | Cstr_tuple l -> tree_of_typlist ?printing_context false l | Cstr_record l -> [Otyp_record (List.map tree_of_label l)] -and tree_of_constructor ?printing_context cd = +and tree_of_constructor ?printing_context ~layout ~position cd = let name = Ident.name cd.cd_id in let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in let repr = if not nullary then None else - match Ast_untagged_variants.process_tag_type cd.cd_attributes with + match Variant_runtime.constructor_tag layout position with | Some Null -> Some "@as(null)" | Some Undefined -> Some "@as(undefined)" | Some (String s) -> Some (Printf.sprintf "@as(%S)" s) diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml index 7c4a4214270..ebb8f690a46 100644 --- a/compiler/ml/typedecl.ml +++ b/compiler/ml/typedecl.ml @@ -1584,11 +1584,15 @@ let transl_type_decl env rec_flag sdecl_list = match decl.type_kind with | Type_variant (cstrs, pending_layout) -> Ast_untagged_variants.check_tag_field_conflicts cstrs; - let is_untagged_def = - Ast_untagged_variants.has_untagged decl.type_attributes + let configuration : Variant_runtime.configuration = + { + unboxed = Ast_untagged_variants.has_untagged decl.type_attributes; + tag_name = + Ast_untagged_variants.process_tag_name decl.type_attributes; + } in let layout = - Variant_layout.layout_from_type_variant ~is_untagged_def ~env:newenv + Variant_layout.layout_from_type_variant ~configuration ~env:newenv cstrs in Variant_runtime.complete_layout pending_layout layout; diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml index a98db56e4bc..36606934f74 100644 --- a/compiler/ml/variant_coercion.ml +++ b/compiler/ml/variant_coercion.ml @@ -42,11 +42,12 @@ let variant_has_case_covering_type (* Checks if every case of the variant has the same runtime representation as the target type. *) let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) - ~unboxed (constructors : Types.constructor_declaration list) = + ~unboxed ~layout (constructors : Types.constructor_declaration list) = (* Helper function to check if a constructor has the same runtime representation as the target type *) - let has_same_runtime_representation (c : Types.constructor_declaration) = + let has_same_runtime_representation position + (c : Types.constructor_declaration) = let args = c.cd_args in - let as_payload = Ast_untagged_variants.process_tag_type c.cd_attributes in + let as_payload = Variant_runtime.constructor_tag layout position in match args with | Cstr_tuple [{desc = Tconstr (p, [], _)}] when unboxed -> @@ -132,20 +133,27 @@ let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) (Inline_record_cannot_be_coerced {constructor_name = Ident.name c.cd_id}) in - List.filter_map has_same_runtime_representation constructors + List.mapi has_same_runtime_representation constructors + |> List.filter_map Fun.id let can_try_coerce_variant_to_primitive ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = match typedecl with | { - type_kind = Type_variant (constructors, _); + type_kind = Type_variant (constructors, layout_ref); type_params = []; - type_attributes; + type_representation; } when not (Path.same p Predef.path_bool) -> (* bool is represented as a variant internally, so we need to account for that *) (* TODO(subtype-errors) Report about bool? *) - Some (p, constructors, type_attributes |> Ast_untagged_variants.has_untagged) + let layout = Variant_runtime.get_layout layout_ref in + Some + ( p, + constructors, + layout, + type_representation = Unboxed + || (Variant_runtime.configuration layout).unboxed ) | _ -> None let can_try_coerce_variant_to_primitive_opt p = @@ -153,12 +161,8 @@ let can_try_coerce_variant_to_primitive_opt p = | None -> None | Some p -> can_try_coerce_variant_to_primitive p -let variant_representation_matches (c1_attrs : Parsetree.attributes) - (c2_attrs : Parsetree.attributes) = - match - ( Ast_untagged_variants.process_tag_type c1_attrs, - Ast_untagged_variants.process_tag_type c2_attrs ) - with +let variant_representation_matches tag1 tag2 = + match (tag1, tag2) with | None, None -> true | Some s1, Some s2 when s1 = s2 -> true | _ -> false @@ -182,13 +186,18 @@ type variant_configuration_issue = | Tag_name_not_matching of {left_tag: string option; right_tag: string option} | Incompatible_constructor_count of {constructor_names: string list} -let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) - (a2 : Parsetree.attributes) = +(* Legacy single-payload unboxing is recorded in [type_representation], while + declaration-wide variant configuration is recorded in the layout. *) +let runtime_configuration ~type_representation ~layout = + let ({Variant_runtime.unboxed} as configuration) = + Variant_runtime.configuration layout + in + {configuration with unboxed = type_representation = Types.Unboxed || unboxed} + +let variant_configuration_can_be_coerced (c1 : Variant_runtime.configuration) + (c2 : Variant_runtime.configuration) = let unboxed = - match - ( Ast_untagged_variants.process_untagged a1, - Ast_untagged_variants.process_untagged a2 ) - with + match (c1.unboxed, c2.unboxed) with | true, true | false, false -> Ok () | left, right -> Error @@ -196,10 +205,7 @@ let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) {left_unboxed = left; right_unboxed = right}) in let tag = - match - ( Ast_untagged_variants.process_tag_name a1, - Ast_untagged_variants.process_tag_name a2 ) - with + match (c1.tag_name, c2.tag_name) with | Some tag1, Some tag2 when tag1 = tag2 -> Ok () | None, None -> Ok () | tag1, tag2 -> @@ -245,8 +251,8 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc error = TagName {left_tag; right_tag}; })) -let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors - ~type_attributes = +let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors ~layout + ~unboxed = let polyvariant_runtime_representations = row_fields |> List.filter_map (fun (label, (field : Types.row_field)) -> @@ -259,37 +265,34 @@ let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors then (* Error: At least one polyvariant constructor has a payload. Cannot have payloads. *) Error `PolyvariantConstructorHasPayload - else - let is_unboxed = Ast_untagged_variants.has_untagged type_attributes in - if - List.for_all - (fun polyvariant_value -> - variant_constructors - |> List.exists (fun (c : Types.constructor_declaration) -> - let constructor_name = Ident.name c.cd_id in - match - Ast_untagged_variants.process_tag_type c.cd_attributes - with - | Some (String as_runtime_string) -> - (* `@as("")`, does the configured string match the polyvariant value? *) - as_runtime_string = polyvariant_value - | Some _ -> - (* Any other `@as` can't match since it's by definition not a string *) - false - | None -> ( - (* No `@as` means the runtime representation will be the constructor + else if + List.for_all + (fun polyvariant_value -> + variant_constructors + |> List.mapi (fun position (c : Types.constructor_declaration) -> + let constructor_name = Ident.name c.cd_id in + match Variant_runtime.constructor_tag layout position with + | Some (String as_runtime_string) -> + (* `@as("")`, does the configured string match the polyvariant value? *) + as_runtime_string = polyvariant_value + | Some _ -> + (* Any other `@as` can't match since it's by definition not a string *) + false + | None -> ( + (* No `@as` means the runtime representation will be the constructor name as a string. However, there's a special case with unboxed types where there's a string catch-all case. In that case, any polyvariant will match, since the catch-all case will match any string. *) - match (is_unboxed, c.cd_args) with - | true, Cstr_tuple [{desc = Tconstr (p, _, _)}] -> - Path.same p Predef.path_string - | _ -> polyvariant_value = constructor_name))) - polyvariant_runtime_representations - then Ok () - else Error `Unknown + match (unboxed, c.cd_args) with + | true, Cstr_tuple [{desc = Tconstr (p, _, _)}] -> + Path.same p Predef.path_string + | _ -> polyvariant_value = constructor_name)) + |> List.exists Fun.id) + polyvariant_runtime_representations + then Ok () + else Error `Unknown let type_is_variant (typ : (Path.t * Path.t * Types.type_declaration) option) = match typ with diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 2ca68466862..9a3ec21fc95 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -59,7 +59,7 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : Some ObjectType | true, _ -> None (* TODO: add restrictions here *) -let layout_from_type_variant ?(is_untagged_def = false) ~env +let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = { @@ -83,9 +83,9 @@ let layout_from_type_variant ?(is_untagged_def = false) ~env | Constant tag -> ((loc, tag) :: consts, blocks) | Block block -> (consts, (loc, block) :: blocks)) in - check_invariant ~is_untagged_def ~consts ~blocks; + check_invariant ~is_untagged_def:configuration.unboxed ~consts ~blocks; let constructors = Array.of_list (List.map (fun (_, constructor) -> constructor) located_constructors) in - Variant_runtime.make_layout constructors + Variant_runtime.make_layout ~configuration constructors diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 19532389de3..4730fc3d5cb 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -93,6 +93,8 @@ type block = {runtime: block_runtime; block_type: block_type option} type constructor_case = Constant of tag | Block of block +type configuration = {unboxed: bool; tag_name: string option} + type matching_facts = { tag_name: string option; (** Custom object field containing constructor tags. [None] means the @@ -111,6 +113,7 @@ type matching_facts = { default, guard, or exhaustiveness information. *) type layout = { + unboxed: bool; constructors: constructor_case array; matching_facts: matching_facts; } @@ -139,6 +142,16 @@ let get_layout layout_ref = let constructor_at (layout : layout) position = layout.constructors.(position) +let constructor_tag layout position = + match constructor_at layout position with + | Constant tag -> tag.tag_type + | Block {runtime = {tag}} -> tag.tag_type + +let constructor_is_untagged layout position = + match constructor_at layout position with + | Constant _ -> false + | Block {runtime = {untagged}} -> untagged + let representation ({variant; position} : constructor_reference) = constructor_at (get_layout variant) position @@ -160,9 +173,8 @@ let num_blocks (layout : layout) = | Constant _ -> n) 0 layout.constructors -let compute_matching_facts (constructors : constructor_case array) : +let compute_matching_facts ~tag_name (constructors : constructor_case array) : matching_facts = - let tag_name = ref None in let block_types = ref [] in let literal_tags = ref [] in let has_null = ref false in @@ -182,14 +194,13 @@ let compute_matching_facts (constructors : constructor_case array) : | Undefined -> has_undefined := true | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ -> has_other_literal := true) - | Block {runtime = {tag_name = constructor_tag_name}; block_type} -> ( - if !tag_name = None then tag_name := constructor_tag_name; + | Block {block_type} -> ( match block_type with | Some block_type -> block_types := block_type :: !block_types | None -> ())) constructors; { - tag_name = !tag_name; + tag_name; block_types = !block_types; literal_tags = !literal_tags; has_null = !has_null; @@ -197,11 +208,19 @@ let compute_matching_facts (constructors : constructor_case array) : has_other_literal = !has_other_literal; } -let make_layout constructors = - {constructors; matching_facts = compute_matching_facts constructors} +let make_layout ~(configuration : configuration) constructors = + { + unboxed = configuration.unboxed; + constructors; + matching_facts = + compute_matching_facts ~tag_name:configuration.tag_name constructors; + } let matching_facts layout = layout.matching_facts +let configuration layout = + {unboxed = layout.unboxed; tag_name = layout.matching_facts.tag_name} + let pending_layout () = ref Pending let complete_layout layout_ref layout = @@ -224,4 +243,8 @@ let plain_layout (cases : (string * bool (* has payload *)) list) : layout_ref = } else Constant {name; tag_type = None} in - ref (Complete (make_layout (Array.of_list (List.map case cases)))) + ref + (Complete + (make_layout + ~configuration:{unboxed = false; tag_name = None} + (Array.of_list (List.map case cases)))) diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index defc6c97dcc..0158adf830f 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -52,6 +52,15 @@ type tag = {name: string; tag_type: tag_type option} type block_runtime = {tag: tag; tag_name: string option; untagged: bool} type block = {runtime: block_runtime; block_type: block_type option} type constructor_case = Constant of tag | Block of block +type configuration = { + unboxed: bool; + (** Whether the declaration carries [@unboxed]. This is retained even + when the declaration has no payload constructor, where it cannot be + recovered by inspecting constructor layouts. *) + tag_name: string option; + (** Custom object field containing constructor tags. This is retained + even when the variant currently has no object constructor. *) +} type matching_facts = { tag_name: string option; @@ -67,12 +76,16 @@ type layout_ref type constructor_reference = {variant: layout_ref; position: int} -val make_layout : constructor_case array -> layout +val make_layout : + configuration:configuration -> constructor_case array -> layout val pending_layout : unit -> layout_ref val complete_layout : layout_ref -> layout -> unit val get_layout : layout_ref -> layout val matching_facts : layout -> matching_facts +val configuration : layout -> configuration val constructor_at : layout -> int -> constructor_case +val constructor_tag : layout -> int -> tag_type option +val constructor_is_untagged : layout -> int -> bool val representation : constructor_reference -> constructor_case val length : layout -> int val num_constants : layout -> int