From f76a30fdb41fca28b026f19300cd1ec2cedf781c Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 6 Sep 2026 07:20:24 +0200 Subject: [PATCH 1/6] Fix constant folding of overlapping unboxed variant matches Signed-off-by: Christoph Knittel --- CHANGELOG.md | 2 + compiler/ml/lambda.ml | 8 ++ .../ounit_lambda_constant_tests.ml | 54 ++++++++++++ .../expected/unboxed_variant_overlap.res.txt | 24 +++++ .../ast-mapping/unboxed_variant_overlap.res | 24 +++++ .../src/unboxed_variant_overlap_test.mjs | 88 +++++++++++++++++++ .../src/unboxed_variant_overlap_test.res | 70 +++++++++++++++ 7 files changed, 270 insertions(+) create mode 100644 tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt create mode 100644 tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res create mode 100644 tests/tests/src/unboxed_variant_overlap_test.mjs create mode 100644 tests/tests/src/unboxed_variant_overlap_test.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 031f43df1f..d8624779be 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,6 +36,8 @@ #### :bug: Bug fix +- Fix constant folding of pattern matches on unboxed variants whose payload overlaps a literal constructor, so inlined calls agree with runtime matching. https://github.com/rescript-lang/rescript/issues/6950 + - Fix escaped backticks and interpolation openers in backquoted `%raw`, `%ffi`, and `%re` payloads leaking into emitted JavaScript. https://github.com/rescript-lang/rescript/pull/8630 - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 825030ccc1..047a772e66 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -806,6 +806,14 @@ let switch lam (lam_switch : lambda_switch) : t = | Switch_int _ | Switch_constructor _ -> None) in action_or_switch action + | Lconst + (Const_block + ( ( Blk_constructor {runtime = {untagged = true}} + | Blk_record_inlined {runtime = {untagged = true}} ), + _ )) -> + (* An untagged payload can have the same runtime value as a literal + constructor. Its source constructor does not determine the match. *) + Lswitch (lam, lam_switch) | Lconst (Const_block (tag_info, _)) -> let runtime = match tag_info with diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index 242139c5c4..18807c3ef9 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -2,9 +2,63 @@ open OUnit let ( =~ ) = OUnit.assert_equal +let constructor_switch ~untagged ~with_block_case = + let runtime : Variant_runtime.block_runtime = + {tag = {name = "Color"; literal = None}; tag_name = None; untagged} + in + let literal : Variant_runtime.tag = + {name = "Primary"; literal = Some (String "primary")} + in + let block : Variant_runtime.block = + {runtime; block_type = (if untagged then Some StringType else None)} + in + let literal_action = Lambda.const (Const_string "literal") in + let block_action = Lambda.const (Const_string "payload") in + let default_action = Lambda.const (Const_string "default") in + let arg = + Lambda.const + (Const_block + ( Blk_constructor {name = "Color"; num_nonconst = 1; runtime}, + [Const_string "primary"] )) + in + let layout = + Variant_runtime.make_layout + ~configuration:{unboxed = untagged; tag_name = None} + [|Constant literal; Block block|] + in + let sw : Lambda.lambda_switch = + { + sw_consts_full = true; + sw_consts = [(Switch_constructor (Constant literal), literal_action)]; + sw_blocks_full = with_block_case; + sw_blocks = + (if with_block_case then + [(Switch_constructor (Block block), block_action)] + else []); + sw_failaction = (if with_block_case then None else Some default_action); + sw_dispatch = Switch_variant (Variant_runtime.matching_facts layout); + } + in + let result = Lambda.switch arg sw in + if untagged then + match result with + | Lswitch (actual_arg, actual_sw) -> + arg =~ actual_arg; + sw =~ actual_sw + | _ -> assert_failure "untagged payload must retain runtime dispatch" + else (if with_block_case then block_action else default_action) =~ result + let suites = __FILE__ >::: [ + ( "untagged switch keeps literal dispatch" >:: fun _ -> + constructor_switch ~untagged:true ~with_block_case:true ); + ( "untagged switch does not prematurely select default" >:: fun _ -> + constructor_switch ~untagged:true ~with_block_case:false ); + ( "tagged switch still folds" >:: fun _ -> + constructor_switch ~untagged:false ~with_block_case:true ); + ( "tagged switch still folds to default" >:: fun _ -> + constructor_switch ~untagged:false ~with_block_case:false ); ( "typed string constants" >:: fun _ -> Lambda.const_string "value" =~ Lambda.Const_string "value" ); ( "compiler-generated strings normalize malformed bytes" >:: fun _ -> diff --git a/tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt b/tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt new file mode 100644 index 0000000000..61ce27a58e --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt @@ -0,0 +1,24 @@ +@unboxed +type color = + | @as("primary") Primary + | @as("secondary") Secondary + | Color(string) + +let colorName = value => + switch value { + | Color(name) => name + | _ => "not Color" + } + +let folded = colorName(Color("primary")) + +@unboxed +type number = | @as(1) One | Number(int) + +let numberName = value => + switch value { + | One => "one" + | Number(_) => "number" + } + +let foldedNumber = numberName(Number(1)) diff --git a/tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res b/tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res new file mode 100644 index 0000000000..97d0a70803 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res @@ -0,0 +1,24 @@ +@unboxed +type color = + | @as("primary") Primary + | @as("secondary") Secondary + | Color(string) + +let colorName = value => + switch value { + | Color(name) => name + | _ => "not Color" + } + +let folded = colorName(Color("primary")) + +@unboxed +type number = @as(1) One | Number(int) + +let numberName = value => + switch value { + | One => "one" + | Number(_) => "number" + } + +let foldedNumber = numberName(Number(1)) diff --git a/tests/tests/src/unboxed_variant_overlap_test.mjs b/tests/tests/src/unboxed_variant_overlap_test.mjs new file mode 100644 index 0000000000..fb1d37b642 --- /dev/null +++ b/tests/tests/src/unboxed_variant_overlap_test.mjs @@ -0,0 +1,88 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function colorName(value) { + if (value === "primary" || value === "secondary") { + return "not Color"; + } else { + return value; + } +} + +function isPrimary(value) { + return value === "primary"; +} + +function numberName(value) { + if (value === 1) { + return "one"; + } else { + return "number"; + } +} + +let foldedPrimary = colorName("primary"); + +let foldedSecondary = colorName("secondary"); + +let foldedBlue = colorName("blue"); + +let foldedDefault = isPrimary("primary"); + +let foldedNumber = numberName(1); + +let foldedOtherNumber = numberName(2); + +let runtimeColorName = colorName; + +let runtimeNumberName = numberName; + +let primary = "primary"; + +let throughBinding = colorName(primary); + +function boxedName(value) { + if (typeof value !== "object") { + return "not Color"; + } else { + return value._0; + } +} + +let foldedBoxed = "primary"; + +Mocha.describe("Unboxed_variant_overlap_test", () => { + Mocha.test("unboxed variant folding agrees with runtime literal dispatch", () => { + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 59, characters 7-14", foldedPrimary, "not Color"); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 60, characters 7-14", foldedSecondary, "not Color"); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 61, characters 7-14", foldedBlue, "blue"); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 62, characters 7-14", foldedDefault, true); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 63, characters 7-14", foldedNumber, "one"); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 64, characters 7-14", foldedOtherNumber, "number"); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 65, characters 7-14", foldedPrimary, runtimeColorName("primary")); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 66, characters 7-14", foldedNumber, runtimeNumberName(1)); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 67, characters 7-14", throughBinding, "not Color"); + Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 68, characters 7-14", foldedBoxed, "primary"); + }); +}); + +export { + colorName, + isPrimary, + numberName, + foldedPrimary, + foldedSecondary, + foldedBlue, + foldedDefault, + foldedNumber, + foldedOtherNumber, + runtimeColorName, + runtimeNumberName, + primary, + throughBinding, + boxedName, + foldedBoxed, +} +/* foldedPrimary Not a pure module */ diff --git a/tests/tests/src/unboxed_variant_overlap_test.res b/tests/tests/src/unboxed_variant_overlap_test.res new file mode 100644 index 0000000000..fafd64a013 --- /dev/null +++ b/tests/tests/src/unboxed_variant_overlap_test.res @@ -0,0 +1,70 @@ +open Mocha +open Test_utils + +@unboxed +type color = + | @as("primary") Primary + | @as("secondary") Secondary + | Color(string) + +let colorName = value => + switch value { + | Color(name) => name + | _ => "not Color" + } + +let isPrimary = value => + switch value { + | Primary => true + | _ => false + } + +@unboxed +type number = | @as(1) One | Number(int) + +let numberName = value => + switch value { + | One => "one" + | Number(_) => "number" + } + +let foldedPrimary = colorName(Color("primary")) +let foldedSecondary = colorName(Color("secondary")) +let foldedBlue = colorName(Color("blue")) +let foldedDefault = isPrimary(Color("primary")) +let foldedNumber = numberName(Number(1)) +let foldedOtherNumber = numberName(Number(2)) + +// Keep runtime calls across an opaque boundary for comparison with inlining. +@inline(never) +let runtimeColorName = value => colorName(value) +@inline(never) +let runtimeNumberName = value => numberName(value) + +// Values flowing through bindings must preserve the same behavior. +let primary = Color("primary") +let throughBinding = colorName(primary) + +// Ordinary boxed variants must keep their distinct constructor identity. +type boxed = | @as("primary") BoxedPrimary | BoxedColor(string) +let boxedName = value => + switch value { + | BoxedPrimary => "not Color" + | BoxedColor(name) => name + } +let foldedBoxed = boxedName(BoxedColor("primary")) + +describe(__MODULE__, () => { + test("unboxed variant folding agrees with runtime literal dispatch", () => { + eq(__LOC__, foldedPrimary, "not Color") + eq(__LOC__, foldedSecondary, "not Color") + eq(__LOC__, foldedBlue, "blue") + eq(__LOC__, foldedDefault, true) + eq(__LOC__, foldedNumber, "one") + eq(__LOC__, foldedOtherNumber, "number") + eq(__LOC__, foldedPrimary, runtimeColorName(Color("primary"))) + eq(__LOC__, foldedNumber, runtimeNumberName(Number(1))) + eq(__LOC__, throughBinding, "not Color") + eq(__LOC__, foldedBoxed, "primary") + }) +}) From 84c4fedc82a879021340331ef83c8f94d2ec7e65 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 6 Sep 2026 07:21:02 +0200 Subject: [PATCH 2/6] Link unboxed variant fix changelog to PR #8631 Signed-off-by: Christoph Knittel --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d8624779be..fefe8f0b85 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,7 +36,7 @@ #### :bug: Bug fix -- Fix constant folding of pattern matches on unboxed variants whose payload overlaps a literal constructor, so inlined calls agree with runtime matching. https://github.com/rescript-lang/rescript/issues/6950 +- Fix constant folding of pattern matches on unboxed variants whose payload overlaps a literal constructor, so inlined calls agree with runtime matching. https://github.com/rescript-lang/rescript/pull/8631 - Fix escaped backticks and interpolation openers in backquoted `%raw`, `%ffi`, and `%re` payloads leaking into emitted JavaScript. https://github.com/rescript-lang/rescript/pull/8630 - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 From c1034e64aefb753c36d962ac79057023e4a8f589 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 6 Sep 2026 07:45:30 +0200 Subject: [PATCH 3/6] Remove extra changelog blank line Signed-off-by: Christoph Knittel --- CHANGELOG.md | 1 - 1 file changed, 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index fefe8f0b85..08f85c0cc4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -37,7 +37,6 @@ #### :bug: Bug fix - Fix constant folding of pattern matches on unboxed variants whose payload overlaps a literal constructor, so inlined calls agree with runtime matching. https://github.com/rescript-lang/rescript/pull/8631 - - Fix escaped backticks and interpolation openers in backquoted `%raw`, `%ffi`, and `%re` payloads leaking into emitted JavaScript. https://github.com/rescript-lang/rescript/pull/8630 - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 From 740334244e24a785f2423321d3d1c60222c47797 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 6 Sep 2026 12:47:14 +0200 Subject: [PATCH 4/6] Fold unboxed variant matches by runtime value Adapt canonical constants and value-based dispatch from c32a837f1. Preserve safe folds while distinguishing arrays, the empty list, bigint spellings, and 32-bit integer tags. Replace the bailout tests with differential runtime coverage and value-based Lambda assertions. Co-authored-by: Cristiano Calcagno Signed-off-by: Christoph Knittel --- compiler/ml/lambda.ml | 146 +++++++++- compiler/ml/lambda.mli | 6 + compiler/ml/translcore.ml | 2 +- .../ounit_lambda_constant_tests.ml | 268 ++++++++++++++---- .../expected/unboxed_variant_overlap.res.txt | 24 -- .../ast-mapping/unboxed_variant_overlap.res | 24 -- tests/tests/src/VariantCoercion.mjs | 12 +- tests/tests/src/unboxed_variant_fold_test.mjs | 211 ++++++++++++++ tests/tests/src/unboxed_variant_fold_test.res | 188 ++++++++++++ .../src/unboxed_variant_overlap_test.mjs | 88 ------ .../src/unboxed_variant_overlap_test.res | 70 ----- 11 files changed, 750 insertions(+), 289 deletions(-) delete mode 100644 tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt delete mode 100644 tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res create mode 100644 tests/tests/src/unboxed_variant_fold_test.mjs create mode 100644 tests/tests/src/unboxed_variant_fold_test.res delete mode 100644 tests/tests/src/unboxed_variant_overlap_test.mjs delete mode 100644 tests/tests/src/unboxed_variant_overlap_test.res diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 047a772e66..0b9d86f6fb 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -422,6 +422,14 @@ let const_constructor (tag : Variant_runtime.tag) = | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) | _ -> Const_constructor tag +(* An untagged constructor has no runtime existence: [Color("primary")] is the + string "primary", exactly as [Primary] is. Erasing the wrapper lets folding + inspect the payload rather than a constructor the runtime cannot see. *) +let const_block (tag_info : tag_info) (args : structured_constant list) = + match (tag_info, args) with + | Blk_constructor {runtime = {untagged = true}}, [payload] -> payload + | _ -> Const_block (tag_info, args) + (* A constructor with an optional shape carries no payload when constant. *) let const_shape_none = Const_js_undefined {is_unit = false} @@ -773,6 +781,87 @@ and eq_option l1 l2 = and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx +(* Classify constants by the JavaScript value emitted by [Lam_compile_const] + and [Js_dump], not by their source constructor. Unknown representations + must retain runtime dispatch. *) +type value_kind = + | Is_literal of Variant_runtime.literal_tag + | Is_object + | Is_array + | Unknown_value + +let rec runtime_value_kind (c : structured_constant) = + match c with + | Const_string s -> Is_literal (String s) + | Const_int i -> Is_literal (Int (Int32.to_int i)) + | Const_float f -> Is_literal (Float f) + | Const_js_true -> Is_literal (Bool true) + | Const_js_false -> Is_literal (Bool false) + | Const_js_null -> Is_literal Null + | Const_js_undefined _ -> Is_literal Undefined + | Const_polyvar name -> Is_literal (String name) + | Const_constructor {name = "[]"; literal = None} -> Is_literal (Int 0) + | Const_constructor {name; literal = None} -> Is_literal (String name) + | Const_constructor {literal = Some (BigInt _)} -> Unknown_value + | Const_constructor {literal = Some literal} -> Is_literal literal + | Const_block (Blk_constructor {runtime = {untagged = true}}, args) -> ( + (* Also handle wrappers in constants read from existing compiler data. *) + match args with + | [payload] -> runtime_value_kind payload + | _ -> Unknown_value) + | Const_block (Blk_tuple, _) -> Is_array + | Const_block (Blk_record {fields}, _) -> + if + Array.length fields <> 0 + && Ext_array.for_alli fields (fun i (name, _) -> string_of_int i = name) + then Is_array + else Is_object + | Const_block + ( ( Blk_constructor _ | Blk_record_inlined _ | Blk_poly_var + | Blk_record_ext _ | Blk_module _ | Blk_module_export _ | Blk_extension + ), + _ ) -> + Is_object + | Const_char _ | Const_bigint _ | Const_some _ | Const_module_alias + | Const_assertfalse -> + Unknown_value + +(* Runtime equality, rather than equality of tags: [@as(1)] and a payload + [1.0] are the same JavaScript number. Bigint spellings are not compared; + both bigint payloads and bigint constructors are classified as unknown. + Integer tags are emitted through [Int32.of_int], just like [Const_int]. *) +let literal_denotes_same (a : Variant_runtime.literal_tag) + (b : Variant_runtime.literal_tag) = + match (a, b) with + | String x, String y -> x = y + | Int x, Int y -> Int32.of_int x = Int32.of_int y + | Float x, Float y -> float_of_string x = float_of_string y + | Int x, Float y | Float y, Int x -> + Int32.to_float (Int32.of_int x) = float_of_string y + | Bool x, Bool y -> x = y + | Null, Null | Undefined, Undefined -> true + | (String _ | Int _ | Float _ | Bool _ | BigInt _ | Null | Undefined), _ -> + false + +(* Mirror [Dynamic_checks]: literals take precedence; the object case excludes + arrays when an array case exists. Int and float share one runtime type. *) +let value_has_block_type ~block_types (kind : value_kind) + (block_type : Variant_runtime.block_type) = + match (block_type, kind) with + | (IntType | FloatType), Is_literal (Int _ | Float _) -> true + | StringType, Is_literal (String _) -> true + | BooleanType, Is_literal (Bool _) -> true + | ObjectType, Is_object -> true + | InstanceType Array, Is_array -> true + | ObjectType, Is_array -> + not (List.mem (Variant_runtime.InstanceType Array) block_types) + | UnknownType, (Is_literal _ | Is_object | Is_array) -> true + | UnknownType, Unknown_value -> false + | ( ( IntType | FloatType | StringType | BooleanType | ObjectType | BigintType + | FunctionType | InstanceType _ ), + _ ) -> + false + let switch lam (lam_switch : lambda_switch) : t = let action_or_switch = function | Some action -> action @@ -781,8 +870,49 @@ let switch lam (lam_switch : lambda_switch) : t = | Some action -> action | None -> Lswitch (lam, lam_switch)) in - match lam with - | Lconst (Const_constructor cstr_name) -> + (* An untagged variant is dispatched on the value, so a constant scrutinee is + decided here rather than by the constructor it was written with - which + has no runtime existence and may be shared with a literal constructor. + [`Undecided] means this layer cannot name the constant's runtime shape, so + the switch has to stay; it is not the same as "no case matches". *) + let untagged_action (facts : Variant_runtime.matching_facts) cst = + let find_in cases matches = + `Case + (Ext_list.find_opt cases (fun (key, action) -> + match key with + | Switch_constructor case when matches case -> Some action + | Switch_int _ | Switch_constructor _ -> None)) + in + let literal_of_tag (tag : Variant_runtime.tag) = + match tag.literal with + | Some literal -> literal + | None -> Variant_runtime.String tag.name + in + let matches_block = value_has_block_type ~block_types:facts.block_types in + let kind = runtime_value_kind cst in + match kind with + | Unknown_value -> `Undecided + | Is_literal literal + when Ext_list.exists facts.literal_tags (literal_denotes_same literal) -> + (* The literal side wins, exactly as it does at runtime. *) + find_in lam_switch.sw_consts (function + | Constant tag -> literal_denotes_same literal (literal_of_tag tag) + | Block _ -> false) + | Is_literal _ | Is_object | Is_array -> + (* Not a declared literal, so the payload's runtime shape decides. *) + if Ext_list.exists facts.block_types (matches_block kind) then + find_in lam_switch.sw_blocks (function + | Block {block_type = Some block_type} -> + matches_block kind block_type + | Constant _ | Block {block_type = None} -> false) + else `Undecided + in + match (lam, lam_switch.sw_dispatch) with + | Lconst cst, Switch_variant ({block_types = _ :: _} as facts) -> ( + match untagged_action facts cst with + | `Case action -> action_or_switch action + | `Undecided -> Lswitch (lam, lam_switch)) + | Lconst (Const_constructor cstr_name), _ -> let action = Ext_list.find_opt lam_switch.sw_consts (fun (key, action) -> match key with @@ -791,7 +921,7 @@ let switch lam (lam_switch : lambda_switch) : t = | Switch_int _ | Switch_constructor _ -> None) in action_or_switch action - | Lconst (Const_int i) -> + | Lconst (Const_int i), _ -> (* 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 *) let i = Int32.to_int i in @@ -806,15 +936,7 @@ let switch lam (lam_switch : lambda_switch) : t = | Switch_int _ | Switch_constructor _ -> None) in action_or_switch action - | Lconst - (Const_block - ( ( Blk_constructor {runtime = {untagged = true}} - | Blk_record_inlined {runtime = {untagged = true}} ), - _ )) -> - (* An untagged payload can have the same runtime value as a literal - constructor. Its source constructor does not determine the match. *) - Lswitch (lam, lam_switch) - | Lconst (Const_block (tag_info, _)) -> + | Lconst (Const_block (tag_info, _)), _ -> let runtime = match tag_info with | Blk_constructor {runtime} | Blk_record_inlined {runtime} -> Some runtime diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 4a3d81b577..1345abb81f 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -432,6 +432,12 @@ val const_string : string -> structured_constant val const_of_typed : constant -> structured_constant val const_unit : structured_constant val const_constructor : Variant_runtime.tag -> structured_constant + +val const_block : tag_info -> structured_constant list -> structured_constant +(** Build a constant block, erasing the wrapper of an untagged constructor: + its payload alone is the runtime value. Inline records remain blocks, + since their fields form a runtime object. *) + val const_shape_none : structured_constant val const_polyvar : string -> structured_constant val const_polyvar_name : string -> structured_constant diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 0c0f5365bc..3772446f28 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1193,7 +1193,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = runtime; } in - try const (Const_block (tag_info, List.map extract_constant ll)) + try const (Lambda.const_block tag_info (List.map extract_constant ll)) with Not_constant -> prim ~primitive:(Pmakeblock tag_info) ~args:ll e.exp_loc) | Extension_constructor path -> diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index 18807c3ef9..74a04e5005 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -2,73 +2,215 @@ open OUnit let ( =~ ) = OUnit.assert_equal -let constructor_switch ~untagged ~with_block_case = - let runtime : Variant_runtime.block_runtime = - {tag = {name = "Color"; literal = None}; tag_name = None; untagged} - in - let literal : Variant_runtime.tag = - {name = "Primary"; literal = Some (String "primary")} - in - let block : Variant_runtime.block = - {runtime; block_type = (if untagged then Some StringType else None)} - in - let literal_action = Lambda.const (Const_string "literal") in - let block_action = Lambda.const (Const_string "payload") in - let default_action = Lambda.const (Const_string "default") in - let arg = - Lambda.const - (Const_block - ( Blk_constructor {name = "Color"; num_nonconst = 1; runtime}, - [Const_string "primary"] )) - in +let runtime ~untagged name : Variant_runtime.block_runtime = + {tag = {name; literal = None}; tag_name = None; untagged} + +let constructor ~untagged name = + Lambda.Blk_constructor + {name; num_nonconst = 1; runtime = runtime ~untagged name} + +let literal name value : Variant_runtime.constructor_case = + Constant {name; literal = Some value} + +let block name shape : Variant_runtime.constructor_case = + Block {runtime = runtime ~untagged:true name; block_type = Some shape} + +let action s = Lambda.const (Const_string s) + +let variant_switch ~constructors ~cases ~default : Lambda.lambda_switch = let layout = Variant_runtime.make_layout - ~configuration:{unboxed = untagged; tag_name = None} - [|Constant literal; Block block|] + ~configuration:{unboxed = true; tag_name = None} + (Array.of_list constructors) + in + let consts, blocks = + List.partition + (fun (case, _) -> + match case with + | Variant_runtime.Constant _ -> true + | Block _ -> false) + cases + in + let keys = + List.map (fun (case, result) -> + (Lambda.Switch_constructor case, action result)) in - let sw : Lambda.lambda_switch = - { - sw_consts_full = true; - sw_consts = [(Switch_constructor (Constant literal), literal_action)]; - sw_blocks_full = with_block_case; - sw_blocks = - (if with_block_case then - [(Switch_constructor (Block block), block_action)] - else []); - sw_failaction = (if with_block_case then None else Some default_action); - sw_dispatch = Switch_variant (Variant_runtime.matching_facts layout); - } + { + sw_consts_full = List.length consts = Variant_runtime.num_constants layout; + sw_consts = keys consts; + sw_blocks_full = List.length blocks = Variant_runtime.num_blocks layout; + sw_blocks = keys blocks; + sw_failaction = Option.map action default; + sw_dispatch = Switch_variant (Variant_runtime.matching_facts layout); + } + +let assert_fold sw value expected = + action expected =~ Lambda.switch (Lambda.const value) sw + +let assert_deferred sw value = + match Lambda.switch (Lambda.const value) sw with + | Lswitch _ -> () + | _ -> assert_failure "unknown runtime representation must retain dispatch" + +let switch_tests = + let primary = literal "Primary" (String "primary") in + let color = block "Color" StringType in + let color_switch = + variant_switch ~constructors:[primary; color] + ~cases:[(primary, "literal"); (color, "payload")] + ~default:None in - let result = Lambda.switch arg sw in - if untagged then - match result with - | Lswitch (actual_arg, actual_sw) -> - arg =~ actual_arg; - sw =~ actual_sw - | _ -> assert_failure "untagged payload must retain runtime dispatch" - else (if with_block_case then block_action else default_action) =~ result + [ + ( "untagged constants expose their payload" >:: fun _ -> + let tag = constructor ~untagged:true "Color" in + Lambda.Const_string "primary" + =~ Lambda.const_block tag [Const_string "primary"]; + Lambda.Const_string "primary" + =~ Lambda.const_block tag + [Lambda.const_block tag [Const_string "primary"]] ); + ( "boxed constants retain their fields" >:: fun _ -> + let tag = constructor ~untagged:false "Color" in + let fields = [Lambda.Const_string "primary"] in + Lambda.Const_block (tag, fields) =~ Lambda.const_block tag fields ); + ( "inline records remain objects" >:: fun _ -> + let tag = + Lambda.blk_record_inlined + [|("x", false)|] + "Record" 1 + ~runtime:(runtime ~untagged:true "Record") + Asttypes.Immutable + in + let fields = [Lambda.Const_int 1l] in + Lambda.Const_block (tag, fields) =~ Lambda.const_block tag fields ); + ( "literal values precede payload shapes" >:: fun _ -> + assert_fold color_switch (Const_string "primary") "literal"; + assert_fold color_switch (Const_string "blue") "payload"; + assert_fold color_switch + (Const_constructor {name = "Alias"; literal = Some (String "primary")}) + "literal"; + assert_fold color_switch + (Const_block + (constructor ~untagged:true "Color", [Const_string "primary"])) + "literal" ); + ( "declaration literals missing from match select default" >:: fun _ -> + let sw = + variant_switch ~constructors:[primary; color] + ~cases:[(color, "payload")] + ~default:(Some "default") + in + assert_fold sw (Const_string "primary") "default"; + assert_fold sw (Const_string "blue") "payload" ); + ( "absent payload arm selects default" >:: fun _ -> + let sw = + variant_switch ~constructors:[primary; color] + ~cases:[(primary, "literal")] + ~default:(Some "default") + in + assert_fold sw (Const_string "blue") "default" ); + ( "ints and floats use JavaScript numeric equality" >:: fun _ -> + let one = literal "One" (Int 1) in + let number = block "Number" FloatType in + let sw = + variant_switch ~constructors:[one; number] + ~cases:[(one, "literal"); (number, "number")] + ~default:None + in + assert_fold sw (Const_float "1.") "literal"; + assert_fold sw (Const_int 1l) "literal"; + assert_fold sw (Const_float "2.5") "number" ); + ( "integer tag emission truncates to 32 bits" >:: fun _ -> + let one = literal "One" (Int 4294967297) in + let number = block "Number" FloatType in + let sw = + variant_switch ~constructors:[one; number] + ~cases:[(one, "literal"); (number, "number")] + ~default:None + in + assert_fold sw (Const_int 1l) "literal"; + assert_fold sw (Const_float "1.") "literal" ); + ( "array and object constants have distinct runtime shapes" >:: fun _ -> + let array = block "Array" (InstanceType Array) in + let obj = block "Object" ObjectType in + let sw = + variant_switch ~constructors:[array; obj] + ~cases:[(array, "array"); (obj, "object")] + ~default:None + in + assert_fold sw (Const_block (Blk_tuple, [Const_int 1l])) "array"; + assert_fold sw + (Const_block + ( Lambda.blk_record [|("0", false)|] Asttypes.Immutable, + [Const_int 1l] )) + "array"; + assert_fold sw + (Const_block + ( Lambda.blk_record [|("x", false)|] Asttypes.Immutable, + [Const_int 1l] )) + "object" ); + ( "empty list is zero at runtime" >:: fun _ -> + let zero = literal "Zero" (Int 0) in + let values = block "Values" UnknownType in + let sw = + variant_switch ~constructors:[zero; values] + ~cases:[(zero, "zero"); (values, "values")] + ~default:None + in + assert_fold sw (Const_constructor {name = "[]"; literal = None}) "zero" ); + ( "unknown values do not select default" >:: fun _ -> + let one = literal "One" (BigInt "1") in + let value = block "Value" UnknownType in + let sw = + variant_switch ~constructors:[one; value] + ~cases:[(one, "one")] + ~default:(Some "default") + in + List.iter (assert_deferred sw) + [ + Const_bigint (false, "1"); + Const_constructor {name = "DecimalTen"; literal = Some (BigInt "1_0")}; + Const_char 65; + Const_some (Const_int 1l); + ] ); + ( "tagged switch still folds by constructor" >:: fun _ -> + let runtime = runtime ~untagged:false "Color" in + let case = Variant_runtime.Block {runtime; block_type = None} in + let sw = + variant_switch ~constructors:[primary; case] + ~cases:[(primary, "literal"); (case, "payload")] + ~default:None + in + assert_fold sw + (Const_block + (constructor ~untagged:false "Color", [Const_string "primary"])) + "payload"; + let sw = + { + sw with + sw_blocks = []; + sw_blocks_full = false; + sw_failaction = Some (action "default"); + } + in + assert_fold sw + (Const_block + (constructor ~untagged:false "Color", [Const_string "primary"])) + "default" ); + ] let suites = __FILE__ - >::: [ - ( "untagged switch keeps literal dispatch" >:: fun _ -> - constructor_switch ~untagged:true ~with_block_case:true ); - ( "untagged switch does not prematurely select default" >:: fun _ -> - constructor_switch ~untagged:true ~with_block_case:false ); - ( "tagged switch still folds" >:: fun _ -> - constructor_switch ~untagged:false ~with_block_case:true ); - ( "tagged switch still folds to default" >:: fun _ -> - constructor_switch ~untagged:false ~with_block_case:false ); - ( "typed string constants" >:: fun _ -> - Lambda.const_string "value" =~ Lambda.Const_string "value" ); - ( "compiler-generated strings normalize malformed bytes" >:: fun _ -> - let constant = Lambda.const_string "a\xffé" in - constant =~ Lambda.Const_string "aÿé"; - match - Lambda.prim ~primitive:Lambda.Pstringlength - ~args:[Lambda.const constant] - Location.none - with - | Lambda.Lconst (Lambda.Const_int length) -> 3l =~ length - | _ -> OUnit.assert_failure "expected a folded string length" ); - ] + >::: switch_tests + @ [ + ( "typed string constants" >:: fun _ -> + Lambda.const_string "value" =~ Lambda.Const_string "value" ); + ( "compiler-generated strings normalize malformed bytes" >:: fun _ -> + let constant = Lambda.const_string "a\xffé" in + constant =~ Lambda.Const_string "aÿé"; + match + Lambda.prim ~primitive:Lambda.Pstringlength + ~args:[Lambda.const constant] + Location.none + with + | Lambda.Lconst (Lambda.Const_int length) -> 3l =~ length + | _ -> OUnit.assert_failure "expected a folded string length" ); + ] diff --git a/tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt b/tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt deleted file mode 100644 index 61ce27a58e..0000000000 --- a/tests/syntax_tests/data/ast-mapping/expected/unboxed_variant_overlap.res.txt +++ /dev/null @@ -1,24 +0,0 @@ -@unboxed -type color = - | @as("primary") Primary - | @as("secondary") Secondary - | Color(string) - -let colorName = value => - switch value { - | Color(name) => name - | _ => "not Color" - } - -let folded = colorName(Color("primary")) - -@unboxed -type number = | @as(1) One | Number(int) - -let numberName = value => - switch value { - | One => "one" - | Number(_) => "number" - } - -let foldedNumber = numberName(Number(1)) diff --git a/tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res b/tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res deleted file mode 100644 index 97d0a70803..0000000000 --- a/tests/syntax_tests/data/ast-mapping/unboxed_variant_overlap.res +++ /dev/null @@ -1,24 +0,0 @@ -@unboxed -type color = - | @as("primary") Primary - | @as("secondary") Secondary - | Color(string) - -let colorName = value => - switch value { - | Color(name) => name - | _ => "not Color" - } - -let folded = colorName(Color("primary")) - -@unboxed -type number = @as(1) One | Number(int) - -let numberName = value => - switch value { - | One => "one" - | Number(_) => "number" - } - -let foldedNumber = numberName(Number(1)) diff --git a/tests/tests/src/VariantCoercion.mjs b/tests/tests/src/VariantCoercion.mjs index dbd38a8b86..975ee646b7 100644 --- a/tests/tests/src/VariantCoercion.mjs +++ b/tests/tests/src/VariantCoercion.mjs @@ -15,16 +15,14 @@ let CoerceVariants = { let a = "hello"; -let c = 100; - let CoerceWithPayload = { a: a, aa: "First", b: a, bb: "First", - c: c, + c: 100, cc: 2, - d: c, + d: 100, dd: 2 }; @@ -32,15 +30,15 @@ let a$1 = "hello"; let aa = "First"; -let c$1 = "Hi"; +let c = "Hi"; let CoerceFromStringToVariant = { a: a$1, aa: aa, b: a$1, bb: aa, - c: c$1, - cc: c$1 + c: c, + cc: c }; let CoerceFromIntToVariant = { diff --git a/tests/tests/src/unboxed_variant_fold_test.mjs b/tests/tests/src/unboxed_variant_fold_test.mjs new file mode 100644 index 0000000000..7a64490035 --- /dev/null +++ b/tests/tests/src/unboxed_variant_fold_test.mjs @@ -0,0 +1,211 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; + +function colorName(v) { + if (v === "primary" || v === "secondary") { + return "not Color"; + } else { + return v; + } +} + +function numberName(v) { + if (v === 1) { + return "one"; + } else { + return "number"; + } +} + +function pureName(v) { + if (typeof v === "number") { + return "int"; + } else { + return "string"; + } +} + +function optName(v) { + if (v == null) { + if (v === null) { + return "null"; + } else { + return "undef"; + } + } else { + return "obj"; + } +} + +function flagName(v) { + if (v === true) { + return "yes"; + } else { + return "str"; + } +} + +function numName(v) { + if (v === 1) { + return "one"; + } else { + return "float"; + } +} + +function recName(v) { + if (v === "empty") { + return "empty"; + } else { + return "rec"; + } +} + +function pick(v) { + if (v === "a" || v === "b") { + return "lit"; + } else { + return v; + } +} + +function outerName(v) { + if (v === "x") { + return "x"; + } else { + return "w"; + } +} + +function boxedName(v) { + if (typeof v !== "object") { + return "not Color"; + } else { + return v._0; + } +} + +function objectName(value) { + if (Array.isArray(value)) { + return "tuple"; + } else { + return "record"; + } +} + +function listName(value) { + if (value === 0) { + return "zero"; + } else { + return "list"; + } +} + +function bigintName(value) { + if (value === 10n) { + return "one"; + } else { + return "wrapped"; + } +} + +function wideName(value) { + if (value === 1) { + return "one"; + } else { + return "int"; + } +} + +function id(x) { + return x; +} + +Mocha.describe("Unboxed_variant_fold_test", () => { + Mocha.test("folding agrees with runtime dispatch", () => { + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 138, characters 7-14", "not Color", colorName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 139, characters 7-14", "not Color", colorName(id("secondary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 140, characters 7-14", "blue", colorName(id("blue"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 141, characters 7-14", "not Color", colorName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 142, characters 7-14", "one", numberName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 143, characters 7-14", "number", numberName(id(2))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 144, characters 7-14", "one", numberName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 145, characters 7-14", "int", pureName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 146, characters 7-14", "string", pureName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 147, characters 7-14", "obj", optName(id({ + x: 1 + }))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 148, characters 7-14", "null", optName(id(null))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 149, characters 7-14", "undef", optName(id(undefined))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 150, characters 7-14", "str", flagName(id("true"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 151, characters 7-14", "yes", flagName(id(true))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 152, characters 7-14", "one", numName(id(1.0))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 153, characters 7-14", "float", numName(id(2.5))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 154, characters 7-14", "one", numName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 155, characters 7-14", "rec", recName(id({ + y: 1 + }))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 156, characters 7-14", "empty", recName(id("empty"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 157, characters 7-14", "lit", pick(id("a"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 158, characters 7-14", "z", pick(id("z"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 159, characters 7-14", "lit", pick(id("a"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 160, characters 7-14", "w", outerName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 161, characters 7-14", "x", outerName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 162, characters 7-14", "x", outerName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 163, characters 7-14", "primary", boxedName(id({ + TAG: "BoxedColor", + _0: "primary" + }))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 164, characters 7-14", "not Color", boxedName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 165, characters 7-14", "tuple", objectName(id([ + 1, + 2 + ]))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 166, characters 7-14", "record", objectName(id({ + x: 1 + }))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 167, characters 7-14", "zero", listName(id(/* [] */0))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 168, characters 7-14", "list", listName(id({ + hd: 1, + tl: /* [] */0 + }))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 169, characters 7-14", bigintName(10n), bigintName(id(10n))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 170, characters 7-14", "one", wideName(id(1))); + }); + Mocha.test("the folded answers themselves are correct", () => { + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 174, characters 7-14", "not Color", "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 175, characters 7-14", "blue", "blue"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 176, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 177, characters 7-14", "number", "number"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 178, characters 7-14", "int", "int"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 179, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 180, characters 7-14", "lit", "lit"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 181, characters 7-14", "x", "x"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 182, characters 7-14", "primary", "primary"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 183, characters 7-14", "tuple", "tuple"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 184, characters 7-14", "zero", "zero"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 185, characters 7-14", bigintName(10n), "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 186, characters 7-14", "one", "one"); + }); +}); + +export { + colorName, + numberName, + pureName, + optName, + flagName, + numName, + recName, + pick, + outerName, + boxedName, + objectName, + listName, + bigintName, + wideName, + id, +} +/* Not a pure module */ diff --git a/tests/tests/src/unboxed_variant_fold_test.res b/tests/tests/src/unboxed_variant_fold_test.res new file mode 100644 index 0000000000..abcf785e9a --- /dev/null +++ b/tests/tests/src/unboxed_variant_fold_test.res @@ -0,0 +1,188 @@ +open Mocha +open Test_utils + +/*** +Constant folding a match on an untagged variant must reach the same answer the +generated dispatch does. Constructor identity is not observable at runtime for +these types, so a fold that reads it can disagree with the emitted code. + +Each case below is computed twice: once with the argument in place, so the +optimizer folds it, and once through [id], whose [@inline(never)] keeps the +constant away from the fold and leaves the real dispatch to answer. The two +must agree. +*/ + +@unboxed +type color = + | @as("primary") Primary + | @as("secondary") Secondary + | Color(string) +let colorName = v => + switch v { + | Color(n) => n + | _ => "not Color" + } + +@unboxed type number = | @as(1) One | Number(int) +let numberName = v => + switch v { + | One => "one" + | Number(_) => "number" + } + +// No literal constructors at all, so no overlap is possible. +@unboxed type pure = I(int) | S(string) +let pureName = v => + switch v { + | I(_) => "int" + | S(_) => "string" + } + +@unboxed +type opt = + | @as(null) Nothing + | @as(undefined) Missing + | Obj({x: int}) +let optName = v => + switch v { + | Nothing => "null" + | Missing => "undef" + | Obj(_) => "obj" + } + +@unboxed type flag = | @as(true) Yes | Str(string) +let flagName = v => + switch v { + | Yes => "yes" + | Str(_) => "str" + } + +// @as(1) and a float payload of 1.0 are one JavaScript number. +@unboxed type num = | @as(1) One2 | F(float) +let numName = v => + switch v { + | One2 => "one" + | F(_) => "float" + } + +// An untagged inline record stays an object rather than becoming its payload. +@unboxed type rec_ = | @as("empty") Empty | R({y: int}) +let recName = v => + switch v { + | Empty => "empty" + | R(_) => "rec" + } + +// The overlapping literal is reachable only through the default arm. +@unboxed type c2 = | @as("a") A | @as("b") B | C(string) +let pick = v => + switch v { + | C(s) => s + | _ => "lit" + } + +// A payload that is itself an untagged constant. +@unboxed type inner = | @as("primary") P | I2(string) +@unboxed type outer = | @as("x") X | W(inner) +let outerName = v => + switch v { + | X => "x" + | W(_) => "w" + } + +// An ordinary boxed variant keeps its constructor identity, tag and all. +type boxed = | @as("primary") BoxedPrimary | BoxedColor(string) +let boxedName = v => + switch v { + | BoxedPrimary => "not Color" + | BoxedColor(n) => n + } + +// Tuple constants emit as arrays, and must not select the object case. +@unboxed type objects = Tuple((int, int)) | Record({x: int}) +let objectName = value => + switch value { + | Tuple(_) => "tuple" + | Record(_) => "record" + } + +// The built-in empty-list constructor is the JavaScript number zero. +@unboxed type lists = | @as(0) Zero | Values(list) +let listName = value => + switch value { + | Zero => "zero" + | Values(_) => "list" + } + +// Bigint constructor spellings can differ while their runtime values agree. +@unboxed type bigintInner = | @as(1_0n) DecimalTen +@unboxed type bigintOuter = | @as(10n) BigOne | Wrapped(bigintInner) +let bigintName = value => + switch value { + | BigOne => "one" + | Wrapped(_) => "wrapped" + } + +// Integer constructor tags use the same 32-bit representation as int values. +@unboxed type wide = | @as(4294967297) WideOne | WideInt(int) +let wideName = value => + switch value { + | WideOne => "one" + | WideInt(_) => "int" + } + +@inline(never) let id = x => x + +describe(__MODULE__, () => { + test("folding agrees with runtime dispatch", () => { + eq(__LOC__, colorName(Color("primary")), colorName(id(Color("primary")))) + eq(__LOC__, colorName(Color("secondary")), colorName(id(Color("secondary")))) + eq(__LOC__, colorName(Color("blue")), colorName(id(Color("blue")))) + eq(__LOC__, colorName(Primary), colorName(id(Primary))) + eq(__LOC__, numberName(Number(1)), numberName(id(Number(1)))) + eq(__LOC__, numberName(Number(2)), numberName(id(Number(2)))) + eq(__LOC__, numberName(One), numberName(id(One))) + eq(__LOC__, pureName(I(1)), pureName(id(I(1)))) + eq(__LOC__, pureName(S("x")), pureName(id(S("x")))) + eq(__LOC__, optName(Obj({x: 1})), optName(id(Obj({x: 1})))) + eq(__LOC__, optName(Nothing), optName(id(Nothing))) + eq(__LOC__, optName(Missing), optName(id(Missing))) + eq(__LOC__, flagName(Str("true")), flagName(id(Str("true")))) + eq(__LOC__, flagName(Yes), flagName(id(Yes))) + eq(__LOC__, numName(F(1.0)), numName(id(F(1.0)))) + eq(__LOC__, numName(F(2.5)), numName(id(F(2.5)))) + eq(__LOC__, numName(One2), numName(id(One2))) + eq(__LOC__, recName(R({y: 1})), recName(id(R({y: 1})))) + eq(__LOC__, recName(Empty), recName(id(Empty))) + eq(__LOC__, pick(C("a")), pick(id(C("a")))) + eq(__LOC__, pick(C("z")), pick(id(C("z")))) + eq(__LOC__, pick(A), pick(id(A))) + eq(__LOC__, outerName(W(P)), outerName(id(W(P)))) + eq(__LOC__, outerName(W(I2("x"))), outerName(id(W(I2("x"))))) + eq(__LOC__, outerName(X), outerName(id(X))) + eq(__LOC__, boxedName(BoxedColor("primary")), boxedName(id(BoxedColor("primary")))) + eq(__LOC__, boxedName(BoxedPrimary), boxedName(id(BoxedPrimary))) + eq(__LOC__, objectName(Tuple((1, 2))), objectName(id(Tuple((1, 2))))) + eq(__LOC__, objectName(Record({x: 1})), objectName(id(Record({x: 1})))) + eq(__LOC__, listName(Values(list{})), listName(id(Values(list{})))) + eq(__LOC__, listName(Values(list{1})), listName(id(Values(list{1})))) + eq(__LOC__, bigintName(Wrapped(DecimalTen)), bigintName(id(Wrapped(DecimalTen)))) + eq(__LOC__, wideName(WideInt(1)), wideName(id(WideInt(1)))) + }) + + test("the folded answers themselves are correct", () => { + eq(__LOC__, colorName(Color("primary")), "not Color") + eq(__LOC__, colorName(Color("blue")), "blue") + eq(__LOC__, numberName(Number(1)), "one") + eq(__LOC__, numberName(Number(2)), "number") + eq(__LOC__, pureName(I(1)), "int") + eq(__LOC__, numName(F(1.0)), "one") + eq(__LOC__, pick(C("a")), "lit") + eq(__LOC__, outerName(W(I2("x"))), "x") + eq(__LOC__, boxedName(BoxedColor("primary")), "primary") + eq(__LOC__, objectName(Tuple((1, 2))), "tuple") + eq(__LOC__, listName(Values(list{})), "zero") + eq(__LOC__, bigintName(Wrapped(DecimalTen)), "one") + eq(__LOC__, wideName(WideInt(1)), "one") + }) +}) diff --git a/tests/tests/src/unboxed_variant_overlap_test.mjs b/tests/tests/src/unboxed_variant_overlap_test.mjs deleted file mode 100644 index fb1d37b642..0000000000 --- a/tests/tests/src/unboxed_variant_overlap_test.mjs +++ /dev/null @@ -1,88 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Mocha from "mocha"; -import * as Test_utils from "./test_utils.mjs"; - -function colorName(value) { - if (value === "primary" || value === "secondary") { - return "not Color"; - } else { - return value; - } -} - -function isPrimary(value) { - return value === "primary"; -} - -function numberName(value) { - if (value === 1) { - return "one"; - } else { - return "number"; - } -} - -let foldedPrimary = colorName("primary"); - -let foldedSecondary = colorName("secondary"); - -let foldedBlue = colorName("blue"); - -let foldedDefault = isPrimary("primary"); - -let foldedNumber = numberName(1); - -let foldedOtherNumber = numberName(2); - -let runtimeColorName = colorName; - -let runtimeNumberName = numberName; - -let primary = "primary"; - -let throughBinding = colorName(primary); - -function boxedName(value) { - if (typeof value !== "object") { - return "not Color"; - } else { - return value._0; - } -} - -let foldedBoxed = "primary"; - -Mocha.describe("Unboxed_variant_overlap_test", () => { - Mocha.test("unboxed variant folding agrees with runtime literal dispatch", () => { - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 59, characters 7-14", foldedPrimary, "not Color"); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 60, characters 7-14", foldedSecondary, "not Color"); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 61, characters 7-14", foldedBlue, "blue"); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 62, characters 7-14", foldedDefault, true); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 63, characters 7-14", foldedNumber, "one"); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 64, characters 7-14", foldedOtherNumber, "number"); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 65, characters 7-14", foldedPrimary, runtimeColorName("primary")); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 66, characters 7-14", foldedNumber, runtimeNumberName(1)); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 67, characters 7-14", throughBinding, "not Color"); - Test_utils.eq("File \"unboxed_variant_overlap_test.res\", line 68, characters 7-14", foldedBoxed, "primary"); - }); -}); - -export { - colorName, - isPrimary, - numberName, - foldedPrimary, - foldedSecondary, - foldedBlue, - foldedDefault, - foldedNumber, - foldedOtherNumber, - runtimeColorName, - runtimeNumberName, - primary, - throughBinding, - boxedName, - foldedBoxed, -} -/* foldedPrimary Not a pure module */ diff --git a/tests/tests/src/unboxed_variant_overlap_test.res b/tests/tests/src/unboxed_variant_overlap_test.res deleted file mode 100644 index fafd64a013..0000000000 --- a/tests/tests/src/unboxed_variant_overlap_test.res +++ /dev/null @@ -1,70 +0,0 @@ -open Mocha -open Test_utils - -@unboxed -type color = - | @as("primary") Primary - | @as("secondary") Secondary - | Color(string) - -let colorName = value => - switch value { - | Color(name) => name - | _ => "not Color" - } - -let isPrimary = value => - switch value { - | Primary => true - | _ => false - } - -@unboxed -type number = | @as(1) One | Number(int) - -let numberName = value => - switch value { - | One => "one" - | Number(_) => "number" - } - -let foldedPrimary = colorName(Color("primary")) -let foldedSecondary = colorName(Color("secondary")) -let foldedBlue = colorName(Color("blue")) -let foldedDefault = isPrimary(Color("primary")) -let foldedNumber = numberName(Number(1)) -let foldedOtherNumber = numberName(Number(2)) - -// Keep runtime calls across an opaque boundary for comparison with inlining. -@inline(never) -let runtimeColorName = value => colorName(value) -@inline(never) -let runtimeNumberName = value => numberName(value) - -// Values flowing through bindings must preserve the same behavior. -let primary = Color("primary") -let throughBinding = colorName(primary) - -// Ordinary boxed variants must keep their distinct constructor identity. -type boxed = | @as("primary") BoxedPrimary | BoxedColor(string) -let boxedName = value => - switch value { - | BoxedPrimary => "not Color" - | BoxedColor(name) => name - } -let foldedBoxed = boxedName(BoxedColor("primary")) - -describe(__MODULE__, () => { - test("unboxed variant folding agrees with runtime literal dispatch", () => { - eq(__LOC__, foldedPrimary, "not Color") - eq(__LOC__, foldedSecondary, "not Color") - eq(__LOC__, foldedBlue, "blue") - eq(__LOC__, foldedDefault, true) - eq(__LOC__, foldedNumber, "one") - eq(__LOC__, foldedOtherNumber, "number") - eq(__LOC__, foldedPrimary, runtimeColorName(Color("primary"))) - eq(__LOC__, foldedNumber, runtimeNumberName(Number(1))) - eq(__LOC__, throughBinding, "not Color") - eq(__LOC__, foldedBoxed, "primary") - }) -}) From 11e2991628a04d119208cf4d3f2f4d1e85e81447 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 6 Sep 2026 13:06:33 +0200 Subject: [PATCH 5/6] Make tagged and untagged variant representations explicit Signed-off-by: Christoph Knittel --- CHANGELOG.md | 2 +- compiler/core/js_dump.ml | 25 ++-- compiler/core/lam_compile.ml | 27 ++--- compiler/ext/config.ml | 4 +- compiler/ml/ast_untagged_variants.ml | 19 +-- compiler/ml/datarepr.ml | 2 +- compiler/ml/lambda.ml | 29 ++--- compiler/ml/lambda.mli | 14 +-- compiler/ml/parmatch.ml | 2 +- compiler/ml/printlambda.ml | 3 +- compiler/ml/translcore.ml | 36 +++--- compiler/ml/typecore_record_rest.ml | 2 +- compiler/ml/typeopt.ml | 4 +- compiler/ml/variant_layout.ml | 51 ++++---- compiler/ml/variant_runtime.ml | 31 ++--- compiler/ml/variant_runtime.mli | 9 +- tests/ERROR_VARIANTS.md | 2 +- ...ructorAttributeMoreThanOneArg.res.expected | 8 ++ ...ggedConstructorAttributeMoreThanOneArg.res | 1 + .../ounit_lambda_constant_tests.ml | 54 ++++----- tests/tests/src/UntaggedVariants.mjs | 4 +- tests/tests/src/unboxed_variant_fold_test.mjs | 113 +++++++++++------- tests/tests/src/unboxed_variant_fold_test.res | 16 +++ 23 files changed, 236 insertions(+), 222 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/UntaggedConstructorAttributeMoreThanOneArg.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/UntaggedConstructorAttributeMoreThanOneArg.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 08f85c0cc4..c55251740f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,7 +36,7 @@ #### :bug: Bug fix -- Fix constant folding of pattern matches on unboxed variants whose payload overlaps a literal constructor, so inlined calls agree with runtime matching. https://github.com/rescript-lang/rescript/pull/8631 +- Fix constant folding of pattern matches on unboxed variants whose payload overlaps a literal constructor, so inlined calls agree with runtime matching. Reject multi-argument unboxed constructors instead of crashing. https://github.com/rescript-lang/rescript/pull/8631 - Fix escaped backticks and interpolation openers in backquoted `%raw`, `%ffi`, and `%re` payloads leaking into emitted JavaScript. https://github.com/rescript-lang/rescript/pull/8630 - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 839f2ebcf6..500cabc8da 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -920,21 +920,20 @@ 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 {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)) 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 | Undefined _ when optional -> None | _ -> Some (f, x)) in - if untagged then tails - else - ( Js_op.Lit tag_name, + match p.runtime with + | Untagged _ -> tails + | Tagged {tag; tag_name} -> + ( Js_op.Lit (Option.value tag_name ~default:L.tag), (* TAG:xx for inline records *) match tag.literal with | None -> E.str p.name @@ -944,7 +943,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 {Variant_runtime.tag; tag_name; untagged} = p.runtime in + let {Variant_runtime.tag; tag_name} = p.runtime in let literal = tag.literal in let tag_name = Option.value tag_name ~default:L.tag in let objs = @@ -956,11 +955,10 @@ and expression_desc cxt ~(level : int) f x : cxt = | false, 1 -> Js_op.Lit Literals.tl | _ -> Js_op.Lit ("_" ^ string_of_int i)), e )) - (if !Js_config.debug && (not untagged) && not_is_cons then - [(name_symbol, E.str p.name)] + (if !Js_config.debug && not_is_cons then [(name_symbol, E.str p.name)] else []) in - if untagged || not_is_cons = false then tails + if not_is_cons = false then tails else ( Js_op.Lit tag_name, (* TAG:xx *) @@ -969,14 +967,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Some t -> E.literal_tag t ) :: tails in - let exp = - match objs with - | [(_, e)] when untagged -> e.expression_desc - | _ when untagged -> assert false (* should not happen *) - (* TODO: put restriction on the variant definitions allowed, to make sure this never happens. *) - | _ -> J.Object (None, objs) - in - expression_desc cxt ~level f exp + expression_desc cxt ~level f (J.Object (None, objs)) | Caml_block (_, _, Blk_module_export _) -> assert false | Caml_block (el, _, Blk_tuple) -> expression_desc cxt ~level f (Array el) | Caml_block_tag (e, tag) -> diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index dad8c9eb7a..24160f205c 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -175,18 +175,10 @@ let tag_of_switch_key = function | Lambda.Switch_int _ -> None | Switch_constructor (Constant tag) -> Some (Variant_runtime.to_matchable_tag tag) - | Switch_constructor - (Block - { - runtime = {tag = {name}; untagged = true}; - block_type = Some block_type; - }) -> + | Switch_constructor (Block (Untagged {tag = {name}; block_type})) -> Some {name; tag_type = Some (Untagged block_type)} - | Switch_constructor (Block {runtime = {untagged = false; tag}}) -> + | Switch_constructor (Block (Tagged {tag})) -> Some (Variant_runtime.to_matchable_tag tag) - | Switch_constructor (Block {runtime = {untagged = true}; block_type = None}) - -> - assert false let dispatch_info = function | Lambda.Switch_direct -> (Js_dump_lit.tag, [], [], (false, false, false)) @@ -858,7 +850,8 @@ let compile output_prefix = in E.emit_check check in - let tag_is_not_typeof = function + let tag_is_not_typeof (tag : Variant_runtime.tag_type) = + match tag with | Variant_runtime.Untagged (InstanceType _) -> true | _ -> false in @@ -870,14 +863,19 @@ let compile output_prefix = let has_object_typeof = List.exists (function - | Variant_runtime.Untagged ObjectType, _ -> true + | ( (Variant_runtime.Untagged ObjectType : Variant_runtime.tag_type), + _ ) -> + true | _ -> false) typeof_clauses in let clauses_have_array_case = List.exists (function - | Variant_runtime.Untagged (InstanceType Array), _ -> true + | ( (Variant_runtime.Untagged (InstanceType Array) : + Variant_runtime.tag_type), + _ ) -> + true | _ -> false) not_typeof_clauses in @@ -895,7 +893,8 @@ let compile output_prefix = let needs_array_guard = has_object_typeof && type_has_array_case && not clauses_have_array_case in - let rec build_if_chain remaining_clauses = + let rec build_if_chain + (remaining_clauses : (Variant_runtime.tag_type * _) list) = match remaining_clauses with | ( Variant_runtime.Untagged (InstanceType instance_type), {J.switch_body} ) diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index 6225cf4bfd..30318442fa 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I033" +let cmi_magic_number = "Caml1999I034" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T035" +and cmt_magic_number = "Caml1999T036" let load_path = ref ([] : string list) diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index dddc716050..8af8c888c0 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -210,8 +210,7 @@ let process_tag_name (attrs : Parsetree.attributes) = (* A constructor the compiler generates itself carries no annotations. *) let generated_tag ~name = {name; literal = None} -let generated_block_runtime ~name = - {tag = generated_tag ~name; tag_name = None; untagged = false} +let generated_block_runtime ~name = {tag = generated_tag ~name; tag_name = None} let is_nullary_variant (x : Types.constructor_arguments) = match x with @@ -295,8 +294,8 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) check_literal ~is_const:true ~loc literal); if is_untagged_def then Ext_list.rev_iter blocks (fun (loc, block) -> - match block.block_type with - | Some block_type -> + match block with + | Untagged {tag; block_type} -> (match block_type with | UnknownType -> incr unknown_types | ObjectType -> incr object_types @@ -310,11 +309,15 @@ 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.runtime.tag.name - | None -> ()) + invariant loc tag.name + | Tagged _ -> ()) else Ext_list.rev_iter blocks (fun (loc, block) -> - check_literal ~is_const:false ~loc block.runtime.tag) + let tag = + match block with + | Tagged {tag} | Untagged {tag} -> tag + in + check_literal ~is_const:false ~loc tag) let get_cstr_loc_tag (cstr : Types.constructor_declaration) = (cstr.cd_loc, {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}) @@ -496,7 +499,7 @@ module Dynamic_checks = struct else (* (undefiled + other) || other *) typeof e != object_ - let add_runtime_type_check ~tag_type ~has_null_case + let add_runtime_type_check ~(tag_type : tag_type) ~has_null_case ~(block_cases : block_type list) x y = let instances = Ext_list.filter_map block_cases (function diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml index ab0195b9b0..e5dc848838 100644 --- a/compiler/ml/datarepr.ml +++ b/compiler/ml/datarepr.ml @@ -121,7 +121,7 @@ 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 + | Block (Untagged _) -> true | Constant _ | Block _ -> false) | Extension_constructor _ -> false diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 0b9d86f6fb..5bed56fa7b 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: Variant_runtime.block_runtime; + runtime: Variant_runtime.tagged_block; } | Blk_record_inlined of { name: string; num_nonconst: int; fields: (string * bool (* optional *)) array; mutable_flag: Asttypes.mutable_flag; - runtime: Variant_runtime.block_runtime; + runtime: Variant_runtime.block; } | Blk_tuple | Blk_poly_var @@ -422,14 +422,6 @@ let const_constructor (tag : Variant_runtime.tag) = | Some (Variant_runtime.Int v) -> Const_int (Int32.of_int v) | _ -> Const_constructor tag -(* An untagged constructor has no runtime existence: [Color("primary")] is the - string "primary", exactly as [Primary] is. Erasing the wrapper lets folding - inspect the payload rather than a constructor the runtime cannot see. *) -let const_block (tag_info : tag_info) (args : structured_constant list) = - match (tag_info, args) with - | Blk_constructor {runtime = {untagged = true}}, [payload] -> payload - | _ -> Const_block (tag_info, args) - (* A constructor with an optional shape carries no payload when constant. *) let const_shape_none = Const_js_undefined {is_unit = false} @@ -790,7 +782,7 @@ type value_kind = | Is_array | Unknown_value -let rec runtime_value_kind (c : structured_constant) = +let runtime_value_kind (c : structured_constant) = match c with | Const_string s -> Is_literal (String s) | Const_int i -> Is_literal (Int (Int32.to_int i)) @@ -804,11 +796,6 @@ let rec runtime_value_kind (c : structured_constant) = | Const_constructor {name; literal = None} -> Is_literal (String name) | Const_constructor {literal = Some (BigInt _)} -> Unknown_value | Const_constructor {literal = Some literal} -> Is_literal literal - | Const_block (Blk_constructor {runtime = {untagged = true}}, args) -> ( - (* Also handle wrappers in constants read from existing compiler data. *) - match args with - | [payload] -> runtime_value_kind payload - | _ -> Unknown_value) | Const_block (Blk_tuple, _) -> Is_array | Const_block (Blk_record {fields}, _) -> if @@ -902,9 +889,8 @@ let switch lam (lam_switch : lambda_switch) : t = (* Not a declared literal, so the payload's runtime shape decides. *) if Ext_list.exists facts.block_types (matches_block kind) then find_in lam_switch.sw_blocks (function - | Block {block_type = Some block_type} -> - matches_block kind block_type - | Constant _ | Block {block_type = None} -> false) + | Block (Untagged {block_type}) -> matches_block kind block_type + | Constant _ | Block (Tagged _) -> false) else `Undecided in match (lam, lam_switch.sw_dispatch) with @@ -939,7 +925,8 @@ let switch lam (lam_switch : lambda_switch) : t = | Lconst (Const_block (tag_info, _)), _ -> let runtime = match tag_info with - | Blk_constructor {runtime} | Blk_record_inlined {runtime} -> Some runtime + | Blk_constructor {runtime} -> Some (Variant_runtime.Tagged runtime) + | Blk_record_inlined {runtime} -> Some runtime | Blk_tuple | Blk_poly_var | Blk_record _ | Blk_record_ext _ | Blk_module _ | Blk_module_export _ | Blk_extension -> None @@ -947,7 +934,7 @@ let switch lam (lam_switch : lambda_switch) : t = let action = Ext_list.find_opt lam_switch.sw_blocks (fun (key, action) -> match key with - | Switch_constructor (Block {runtime = case_runtime}) + | Switch_constructor (Block case_runtime) when runtime = Some case_runtime -> Some action | Switch_int _ | Switch_constructor _ -> None) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 1345abb81f..38ffead4b9 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -23,14 +23,16 @@ type tag_info = | Blk_constructor of { name: string; num_nonconst: int; - runtime: Variant_runtime.block_runtime; + runtime: Variant_runtime.tagged_block; + (** Untagged scalar constructors are erased during typedtree + translation; they cannot form Lambda or JavaScript blocks. *) } | Blk_record_inlined of { name: string; num_nonconst: int; fields: (string * bool (* optional *)) array; mutable_flag: mutable_flag; - runtime: Variant_runtime.block_runtime; + runtime: Variant_runtime.block; } | Blk_tuple | Blk_poly_var @@ -62,7 +64,7 @@ val blk_record_inlined : (string * bool) array -> string -> int -> - runtime:Variant_runtime.block_runtime -> + runtime:Variant_runtime.block -> mutable_flag -> tag_info @@ -432,12 +434,6 @@ val const_string : string -> structured_constant val const_of_typed : constant -> structured_constant val const_unit : structured_constant val const_constructor : Variant_runtime.tag -> structured_constant - -val const_block : tag_info -> structured_constant list -> structured_constant -(** Build a constant block, erasing the wrapper of an untagged constructor: - its payload alone is the runtime value. Inline records remain blocks, - since their fields form a runtime object. *) - val const_shape_none : structured_constant val const_polyvar : string -> structured_constant val const_polyvar_name : string -> structured_constant diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 418749f5f9..7cb28e6b07 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -560,7 +560,7 @@ let all_record_args lbls = | Extension_constructor _ -> x | Ordinary_constructor representation -> ( match Variant_runtime.representation representation with - | Block {block_type = Some block_type} + | Block (Untagged {block_type}) when not (Ast_untagged_variants.block_type_can_be_undefined block_type) -> diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 24ff88dfb2..e006d602aa 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -308,7 +308,8 @@ let rec lam ppf = function match key with | Switch_int ordinal -> fprintf ppf "@[case tag %i:@ %a@]" ordinal lam l - | Switch_constructor (Block {runtime = {tag = {name}}}) -> + | Switch_constructor + (Block (Tagged {tag = {name}} | Untagged {tag = {name}})) -> fprintf ppf "@[case constructor %S:@ %a@]" name lam l | Switch_constructor (Constant _) -> assert false) sw.sw_blocks; diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 3772446f28..2756d7438f 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1161,7 +1161,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = | Ordinary_constructor _ -> ( let runtime = match Datarepr.constructor_case cstr with - | Block {runtime} -> runtime + | Block runtime -> runtime | Constant _ -> assert false in if Datarepr.constructor_is_unboxed cstr then @@ -1185,17 +1185,25 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.t = try const (Const_some (extract_constant value)) with Not_constant -> prim ~primitive ~args:ll e.exp_loc else - let tag_info : Lambda.tag_info = - Blk_constructor - { - name = cstr.cstr_name; - num_nonconst = num_nonconst_constructors cstr; - runtime; - } - in - try const (Lambda.const_block tag_info (List.map extract_constant ll)) - with Not_constant -> - prim ~primitive:(Pmakeblock tag_info) ~args:ll e.exp_loc) + match runtime with + | Untagged _ -> ( + (* Untagged payload constructors have no Lambda or JS block. + Their arity has already been validated by the type checker. *) + match ll with + | [value] -> value + | _ -> assert false) + | Tagged runtime -> ( + let tag_info : Lambda.tag_info = + Blk_constructor + { + name = cstr.cstr_name; + num_nonconst = num_nonconst_constructors cstr; + runtime; + } + in + try const (Const_block (tag_info, List.map extract_constant ll)) + with Not_constant -> + prim ~primitive:(Pmakeblock tag_info) ~args:ll e.exp_loc)) | Extension_constructor path -> prim ~primitive:(Pmakeblock Blk_extension) ~args:(Transl_path.transl_extension_path e.exp_env path :: ll) @@ -1507,7 +1515,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_inlined {name; representation} -> let runtime = match Variant_runtime.representation representation with - | Block {runtime} -> runtime + | Block runtime -> runtime | Constant _ -> assert false in let num_nonconsts = @@ -1535,7 +1543,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_inlined {name; representation} -> let runtime = match Variant_runtime.representation representation with - | Block {runtime} -> runtime + | Block runtime -> runtime | Constant _ -> assert false in let num_nonconsts = diff --git a/compiler/ml/typecore_record_rest.ml b/compiler/ml/typecore_record_rest.ml index 820e48ccd5..536ffd4f8f 100644 --- a/compiler/ml/typecore_record_rest.ml +++ b/compiler/ml/typecore_record_rest.ml @@ -103,7 +103,7 @@ let runtime_excluded_labels ~explicit_runtime_labels source_repr = match source_repr with | Record_inlined {representation; _} -> ( match Variant_runtime.representation representation with - | Block {runtime = {untagged = false; tag_name}} -> + | Block (Tagged {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 diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml index 8c64055eab..d5fef7dd0d 100644 --- a/compiler/ml/typeopt.ml +++ b/compiler/ml/typeopt.ml @@ -76,8 +76,8 @@ let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = let tag, payload_is_unboxed = match case with | Variant_runtime.Constant tag -> (tag, false) - | Variant_runtime.Block {runtime = {tag; untagged}} -> - (tag, untagged) + | Variant_runtime.Block (Tagged {tag}) -> (tag, false) + | Variant_runtime.Block (Untagged {tag}) -> (tag, true) in tag.literal <> Some Variant_runtime.Undefined && ((not payload_is_unboxed) diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index b84fb8455a..86013d9772 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -37,40 +37,31 @@ let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = | {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 get_block_type ~env (cstr : Types.constructor_declaration) : block_type = + match cstr.cd_args with + | Cstr_tuple [ty] -> ( + match get_block_type_from_typ ~env ty with + | Some shape -> shape + | None -> ( + match Ctype.extract_concrete_typedecl env ty with + | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> UnknownType + | _, _, {type_kind = Type_record (_, _)} -> ObjectType + | _ -> UnknownType + | exception _ -> UnknownType)) + | Cstr_tuple (_ :: _ :: _) -> + report_constructor_more_than_one_arg ~loc:cstr.cd_loc + ~name:(Ident.name cstr.cd_id) + | Cstr_record _ -> ObjectType + | Cstr_tuple [] -> UnknownType let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = let get_block (cstr : Types.constructor_declaration) : block = - { - runtime = - { - tag = {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag}; - tag_name = process_tag_name cstr.cd_attributes; - untagged = process_untagged cstr.cd_attributes; - }; - block_type = get_block_type ~env cstr; - } + let tag = {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag} in + let tag_name = process_tag_name cstr.cd_attributes in + if process_untagged cstr.cd_attributes then + Untagged {tag; block_type = get_block_type ~env cstr} + else Tagged {tag; tag_name} in let located_constructors = List.map diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 5ee89df843..1134cd75ba 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -95,13 +95,13 @@ type matchable_tag = {name: string; tag_type: tag_type option} (** A constructor tag widened for matching, where an untagged payload shape can participate alongside declared literals. *) -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 tagged_block = {tag: tag; tag_name: string option} -type block = {runtime: block_runtime; block_type: block_type option} +(** An untagged payload always carries the runtime shape used for dispatch. + Only tagged blocks have an emitted tag field. *) +type block = + | Tagged of tagged_block + | Untagged of {tag: tag; block_type: block_type} (* Matching compares against a wider notion of tag than a declaration can state, so a stored tag widens on its way into a check. *) @@ -162,12 +162,13 @@ let constructor_at (layout : layout) position = layout.constructors.(position) let constructor_tag layout position = match constructor_at layout position with | Constant tag -> tag.literal - | Block {runtime = {tag}} -> tag.literal + | Block (Tagged {tag} | Untagged {tag}) -> tag.literal let constructor_is_untagged layout position = match constructor_at layout position with | Constant _ -> false - | Block {runtime = {untagged}} -> untagged + | Block (Tagged _) -> false + | Block (Untagged _) -> true let representation ({variant; position} : constructor_reference) = constructor_at (get_layout variant) position @@ -212,10 +213,9 @@ let compute_matching_facts ~tag_name (constructors : constructor_case array) : | Undefined -> has_undefined := true | String _ | Int _ | Float _ | BigInt _ | Bool _ -> has_other_literal := true) - | Block {block_type} -> ( - match block_type with - | Some block_type -> block_types := block_type :: !block_types - | None -> ())) + | Block (Untagged {block_type}) -> + block_types := block_type :: !block_types + | Block (Tagged _) -> ()) constructors; { tag_name; @@ -253,12 +253,7 @@ let complete_layout layout_ref layout = let plain_layout (cases : (string * bool (* has payload *)) list) : layout_ref = let case (name, has_payload) = if has_payload then - Block - { - runtime = - {tag = {name; literal = None}; tag_name = None; untagged = false}; - block_type = None; - } + Block (Tagged {tag = {name; literal = None}; tag_name = None}) else Constant {name; literal = None} in ref diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index 7dc77ad07a..d30b2676ae 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -59,9 +59,14 @@ type matchable_tag = {name: string; tag_type: tag_type option} (** A constructor tag widened for matching, where an untagged payload shape can participate alongside declared literals. *) -type block_runtime = {tag: tag; tag_name: string option; untagged: bool} +type tagged_block = {tag: tag; tag_name: string option} + +(** An untagged payload always carries the runtime shape used for dispatch. + Only tagged blocks have an emitted tag field. *) +type block = + | Tagged of tagged_block + | Untagged of {tag: tag; block_type: block_type} -type block = {runtime: block_runtime; block_type: block_type option} type constructor_case = Constant of tag | Block of block val to_matchable_tag : tag -> matchable_tag diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 012ca59488..a4d7dc70d6 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -450,7 +450,7 @@ Untagged-variant validation errors. Source: [ast_untagged_variants.ml:52](../com | `AtMostOneBigint` | ✓ | `UntaggedAtMostOneBigint.res` | Two bigint payloads. | | `AtMostOneBoolean` | ✓ | `UntaggedAtMostOneBoolean.res` | Two boolean payloads. | | `DuplicateLiteral` | ✓ | `UntaggedDuplicateLiteral.res` | `@as("x")` on two different constructors. | -| `ConstructorMoreThanOneArg` | ✓ | `UntaggedConstructorMoreThanOneArg.res` | `A(int, int)` payload in an untagged variant. | +| `ConstructorMoreThanOneArg` | ✓ | `UntaggedConstructorMoreThanOneArg.res`, `UntaggedConstructorAttributeMoreThanOneArg.res` | Multiple payload arguments with type-level or constructor-level `@unboxed`. | ### `error` diff --git a/tests/build_tests/super_errors/expected/UntaggedConstructorAttributeMoreThanOneArg.res.expected b/tests/build_tests/super_errors/expected/UntaggedConstructorAttributeMoreThanOneArg.res.expected new file mode 100644 index 0000000000..6e3d991a9b --- /dev/null +++ b/tests/build_tests/super_errors/expected/UntaggedConstructorAttributeMoreThanOneArg.res.expected @@ -0,0 +1,8 @@ + + We've found a bug for you! + /.../fixtures/UntaggedConstructorAttributeMoreThanOneArg.res:1:10-31 + + 1 │ type t = | @unboxed A(int, int) | B + 2 │ + + This untagged variant definition is invalid: Constructor A has more than one argument. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/UntaggedConstructorAttributeMoreThanOneArg.res b/tests/build_tests/super_errors/fixtures/UntaggedConstructorAttributeMoreThanOneArg.res new file mode 100644 index 0000000000..ddb2a6aebc --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/UntaggedConstructorAttributeMoreThanOneArg.res @@ -0,0 +1 @@ +type t = | @unboxed A(int, int) | B diff --git a/tests/ounit_tests/ounit_lambda_constant_tests.ml b/tests/ounit_tests/ounit_lambda_constant_tests.ml index 74a04e5005..5c41811a44 100644 --- a/tests/ounit_tests/ounit_lambda_constant_tests.ml +++ b/tests/ounit_tests/ounit_lambda_constant_tests.ml @@ -2,18 +2,17 @@ open OUnit let ( =~ ) = OUnit.assert_equal -let runtime ~untagged name : Variant_runtime.block_runtime = - {tag = {name; literal = None}; tag_name = None; untagged} +let runtime name : Variant_runtime.tagged_block = + {tag = {name; literal = None}; tag_name = None} -let constructor ~untagged name = - Lambda.Blk_constructor - {name; num_nonconst = 1; runtime = runtime ~untagged name} +let constructor name = + Lambda.Blk_constructor {name; num_nonconst = 1; runtime = runtime name} let literal name value : Variant_runtime.constructor_case = Constant {name; literal = Some value} let block name shape : Variant_runtime.constructor_case = - Block {runtime = runtime ~untagged:true name; block_type = Some shape} + Block (Untagged {tag = {name; literal = None}; block_type = shape}) let action s = Lambda.const (Const_string s) @@ -61,36 +60,29 @@ let switch_tests = ~default:None in [ - ( "untagged constants expose their payload" >:: fun _ -> - let tag = constructor ~untagged:true "Color" in - Lambda.Const_string "primary" - =~ Lambda.const_block tag [Const_string "primary"]; - Lambda.Const_string "primary" - =~ Lambda.const_block tag - [Lambda.const_block tag [Const_string "primary"]] ); - ( "boxed constants retain their fields" >:: fun _ -> - let tag = constructor ~untagged:false "Color" in - let fields = [Lambda.Const_string "primary"] in - Lambda.Const_block (tag, fields) =~ Lambda.const_block tag fields ); ( "inline records remain objects" >:: fun _ -> + let record = block "Record" ObjectType in + let runtime = + match record with + | Block runtime -> runtime + | Constant _ -> assert false + in let tag = Lambda.blk_record_inlined [|("x", false)|] - "Record" 1 - ~runtime:(runtime ~untagged:true "Record") - Asttypes.Immutable + "Record" 1 ~runtime Asttypes.Immutable + in + let sw = + variant_switch ~constructors:[primary; record] + ~cases:[(primary, "literal"); (record, "record")] + ~default:None in - let fields = [Lambda.Const_int 1l] in - Lambda.Const_block (tag, fields) =~ Lambda.const_block tag fields ); + assert_fold sw (Const_block (tag, [Const_int 1l])) "record" ); ( "literal values precede payload shapes" >:: fun _ -> assert_fold color_switch (Const_string "primary") "literal"; assert_fold color_switch (Const_string "blue") "payload"; assert_fold color_switch (Const_constructor {name = "Alias"; literal = Some (String "primary")}) - "literal"; - assert_fold color_switch - (Const_block - (constructor ~untagged:true "Color", [Const_string "primary"])) "literal" ); ( "declaration literals missing from match select default" >:: fun _ -> let sw = @@ -172,16 +164,15 @@ let switch_tests = Const_some (Const_int 1l); ] ); ( "tagged switch still folds by constructor" >:: fun _ -> - let runtime = runtime ~untagged:false "Color" in - let case = Variant_runtime.Block {runtime; block_type = None} in + let runtime = runtime "Color" in + let case = Variant_runtime.Block (Tagged runtime) in let sw = variant_switch ~constructors:[primary; case] ~cases:[(primary, "literal"); (case, "payload")] ~default:None in assert_fold sw - (Const_block - (constructor ~untagged:false "Color", [Const_string "primary"])) + (Const_block (constructor "Color", [Const_string "primary"])) "payload"; let sw = { @@ -192,8 +183,7 @@ let switch_tests = } in assert_fold sw - (Const_block - (constructor ~untagged:false "Color", [Const_string "primary"])) + (Const_block (constructor "Color", [Const_string "primary"])) "default" ); ] diff --git a/tests/tests/src/UntaggedVariants.mjs b/tests/tests/src/UntaggedVariants.mjs index 1b8f5bc551..a9d410ad5a 100644 --- a/tests/tests/src/UntaggedVariants.mjs +++ b/tests/tests/src/UntaggedVariants.mjs @@ -363,7 +363,9 @@ function classify$9(v) { } } -let ff = x => x + 1 | 0; +function ff(x) { + return x + 1 | 0; +} let TestFunctionCase = { classify: classify$9, diff --git a/tests/tests/src/unboxed_variant_fold_test.mjs b/tests/tests/src/unboxed_variant_fold_test.mjs index 7a64490035..b5405a0671 100644 --- a/tests/tests/src/unboxed_variant_fold_test.mjs +++ b/tests/tests/src/unboxed_variant_fold_test.mjs @@ -123,71 +123,90 @@ function id(x) { return x; } +function makeColor(name) { + return name; +} + +function makeRecord(value) { + return { + y: value + }; +} + Mocha.describe("Unboxed_variant_fold_test", () => { + Mocha.test("constructors preserve dynamic payloads and effects", () => { + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 142, characters 7-14", colorName(makeColor("primary")), "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 143, characters 7-14", colorName(makeColor("blue")), "blue"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 144, characters 7-14", recName(makeRecord(1)), "rec"); + let calls = 0; + calls = calls + 1 | 0; + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 150, characters 7-14", colorName("primary"), "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 151, characters 7-14", calls, 1); + }); Mocha.test("folding agrees with runtime dispatch", () => { - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 138, characters 7-14", "not Color", colorName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 139, characters 7-14", "not Color", colorName(id("secondary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 140, characters 7-14", "blue", colorName(id("blue"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 141, characters 7-14", "not Color", colorName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 142, characters 7-14", "one", numberName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 143, characters 7-14", "number", numberName(id(2))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 144, characters 7-14", "one", numberName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 145, characters 7-14", "int", pureName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 146, characters 7-14", "string", pureName(id("x"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 147, characters 7-14", "obj", optName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 154, characters 7-14", "not Color", colorName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 155, characters 7-14", "not Color", colorName(id("secondary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 156, characters 7-14", "blue", colorName(id("blue"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 157, characters 7-14", "not Color", colorName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 158, characters 7-14", "one", numberName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 159, characters 7-14", "number", numberName(id(2))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 160, characters 7-14", "one", numberName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 161, characters 7-14", "int", pureName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 162, characters 7-14", "string", pureName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 163, characters 7-14", "obj", optName(id({ x: 1 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 148, characters 7-14", "null", optName(id(null))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 149, characters 7-14", "undef", optName(id(undefined))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 150, characters 7-14", "str", flagName(id("true"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 151, characters 7-14", "yes", flagName(id(true))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 152, characters 7-14", "one", numName(id(1.0))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 153, characters 7-14", "float", numName(id(2.5))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 154, characters 7-14", "one", numName(id(1))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 155, characters 7-14", "rec", recName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 164, characters 7-14", "null", optName(id(null))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 165, characters 7-14", "undef", optName(id(undefined))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 166, characters 7-14", "str", flagName(id("true"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 167, characters 7-14", "yes", flagName(id(true))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 168, characters 7-14", "one", numName(id(1.0))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 169, characters 7-14", "float", numName(id(2.5))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 170, characters 7-14", "one", numName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 171, characters 7-14", "rec", recName(id({ y: 1 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 156, characters 7-14", "empty", recName(id("empty"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 157, characters 7-14", "lit", pick(id("a"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 158, characters 7-14", "z", pick(id("z"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 159, characters 7-14", "lit", pick(id("a"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 160, characters 7-14", "w", outerName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 161, characters 7-14", "x", outerName(id("x"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 162, characters 7-14", "x", outerName(id("x"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 163, characters 7-14", "primary", boxedName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 172, characters 7-14", "empty", recName(id("empty"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 173, characters 7-14", "lit", pick(id("a"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 174, characters 7-14", "z", pick(id("z"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 175, characters 7-14", "lit", pick(id("a"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 176, characters 7-14", "w", outerName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 177, characters 7-14", "x", outerName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 178, characters 7-14", "x", outerName(id("x"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 179, characters 7-14", "primary", boxedName(id({ TAG: "BoxedColor", _0: "primary" }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 164, characters 7-14", "not Color", boxedName(id("primary"))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 165, characters 7-14", "tuple", objectName(id([ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 180, characters 7-14", "not Color", boxedName(id("primary"))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 181, characters 7-14", "tuple", objectName(id([ 1, 2 ]))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 166, characters 7-14", "record", objectName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 182, characters 7-14", "record", objectName(id({ x: 1 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 167, characters 7-14", "zero", listName(id(/* [] */0))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 168, characters 7-14", "list", listName(id({ + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 183, characters 7-14", "zero", listName(id(/* [] */0))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 184, characters 7-14", "list", listName(id({ hd: 1, tl: /* [] */0 }))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 169, characters 7-14", bigintName(10n), bigintName(id(10n))); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 170, characters 7-14", "one", wideName(id(1))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 185, characters 7-14", bigintName(10n), bigintName(id(10n))); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 186, characters 7-14", "one", wideName(id(1))); }); Mocha.test("the folded answers themselves are correct", () => { - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 174, characters 7-14", "not Color", "not Color"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 175, characters 7-14", "blue", "blue"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 176, characters 7-14", "one", "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 177, characters 7-14", "number", "number"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 178, characters 7-14", "int", "int"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 179, characters 7-14", "one", "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 180, characters 7-14", "lit", "lit"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 181, characters 7-14", "x", "x"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 182, characters 7-14", "primary", "primary"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 183, characters 7-14", "tuple", "tuple"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 184, characters 7-14", "zero", "zero"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 185, characters 7-14", bigintName(10n), "one"); - Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 186, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 190, characters 7-14", "not Color", "not Color"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 191, characters 7-14", "blue", "blue"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 192, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 193, characters 7-14", "number", "number"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 194, characters 7-14", "int", "int"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 195, characters 7-14", "one", "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 196, characters 7-14", "lit", "lit"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 197, characters 7-14", "x", "x"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 198, characters 7-14", "primary", "primary"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 199, characters 7-14", "tuple", "tuple"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 200, characters 7-14", "zero", "zero"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 201, characters 7-14", bigintName(10n), "one"); + Test_utils.eq("File \"unboxed_variant_fold_test.res\", line 202, characters 7-14", "one", "one"); }); }); @@ -207,5 +226,7 @@ export { bigintName, wideName, id, + makeColor, + makeRecord, } /* Not a pure module */ diff --git a/tests/tests/src/unboxed_variant_fold_test.res b/tests/tests/src/unboxed_variant_fold_test.res index abcf785e9a..a83553cdd7 100644 --- a/tests/tests/src/unboxed_variant_fold_test.res +++ b/tests/tests/src/unboxed_variant_fold_test.res @@ -133,7 +133,23 @@ let wideName = value => @inline(never) let id = x => x +// Nonconstant scalar payloads are passed through; inline records remain objects. +@inline(never) let makeColor = name => Color(name) +@inline(never) let makeRecord = value => R({y: value}) + describe(__MODULE__, () => { + test("constructors preserve dynamic payloads and effects", () => { + eq(__LOC__, colorName(makeColor("primary")), "not Color") + eq(__LOC__, colorName(makeColor("blue")), "blue") + eq(__LOC__, recName(makeRecord(1)), "rec") + let calls = ref(0) + let value = Color({ + calls.contents = calls.contents + 1 + "primary" + }) + eq(__LOC__, colorName(value), "not Color") + eq(__LOC__, calls.contents, 1) + }) test("folding agrees with runtime dispatch", () => { eq(__LOC__, colorName(Color("primary")), colorName(id(Color("primary")))) eq(__LOC__, colorName(Color("secondary")), colorName(id(Color("secondary")))) From 3509fdbc2e88f6fc8cf0105ada960ef8a977ede4 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sun, 6 Sep 2026 13:13:13 +0200 Subject: [PATCH 6/6] Distinguish payload matching shapes from untagged representations Rename the matching-only tag_type constructor to Payload_shape, leaving Tagged/Untagged for constructor representations. Remove type annotations that were only needed to distinguish the two Untagged constructors, and document the matching contract. Assert that nullary constructors have already been handled before computing a payload shape. This completes the representation cleanup: ordinary unboxed payload wrappers are erased during typedtree translation, while inline records remain objects. The preceding commit bumped CMI/CMT format versions for the changed serialized representation and rejects multi-argument unboxed constructors before lowering. This rename preserves the serialized layout. Validation: make test, including formatting, compiler unit tests, runtime regressions, build tests, and docstring tests. Lstringswitch is unchanged. Signed-off-by: Christoph Knittel --- compiler/core/js_exp_make.ml | 2 +- compiler/core/js_stmt_make.ml | 2 +- compiler/core/lam_compile.ml | 21 ++++++------------ compiler/ml/ast_untagged_variants.ml | 22 +++++++++---------- compiler/ml/variant_layout.ml | 4 +++- compiler/ml/variant_runtime.ml | 12 ++++------ compiler/ml/variant_runtime.mli | 5 ++++- .../ounit_tests/ounit_string_literal_tests.ml | 2 +- 8 files changed, 32 insertions(+), 38 deletions(-) diff --git a/compiler/core/js_exp_make.ml b/compiler/core/js_exp_make.ml index a1df38f00d..bed0432e2d 100644 --- a/compiler/core/js_exp_make.ml +++ b/compiler/core/js_exp_make.ml @@ -1416,7 +1416,7 @@ let block_type_name = function let tag_type = function | Variant_runtime.Literal d -> literal_tag d - | Untagged b -> block_type_name b + | Payload_shape b -> block_type_name b let rec emit_check (check : t Ast_untagged_variants.Dynamic_checks.t) = match check with diff --git a/compiler/core/js_stmt_make.ml b/compiler/core/js_stmt_make.ml index 214c9c2069..be045cf0c0 100644 --- a/compiler/core/js_stmt_make.ml +++ b/compiler/core/js_stmt_make.ml @@ -150,7 +150,7 @@ let string_switch ?(comment : string option) Ext_list.find_opt clauses (fun (switch_case, x) -> match switch_case with | Literal (String s) -> if s = txt then Some x.switch_body else None - | Literal _ | Untagged _ -> None) + | Literal _ | Payload_shape _ -> None) with | Some case -> case | None -> ( diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 24160f205c..ddfcc13e57 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -176,7 +176,7 @@ let tag_of_switch_key = function | Switch_constructor (Constant tag) -> Some (Variant_runtime.to_matchable_tag tag) | Switch_constructor (Block (Untagged {tag = {name}; block_type})) -> - Some {name; tag_type = Some (Untagged block_type)} + Some {name; tag_type = Some (Payload_shape block_type)} | Switch_constructor (Block (Tagged {tag})) -> Some (Variant_runtime.to_matchable_tag tag) @@ -850,9 +850,8 @@ let compile output_prefix = in E.emit_check check in - let tag_is_not_typeof (tag : Variant_runtime.tag_type) = - match tag with - | Variant_runtime.Untagged (InstanceType _) -> true + let tag_is_not_typeof = function + | Variant_runtime.Payload_shape (InstanceType _) -> true | _ -> false in let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in @@ -863,19 +862,14 @@ let compile output_prefix = let has_object_typeof = List.exists (function - | ( (Variant_runtime.Untagged ObjectType : Variant_runtime.tag_type), - _ ) -> - true + | Variant_runtime.Payload_shape ObjectType, _ -> true | _ -> false) typeof_clauses in let clauses_have_array_case = List.exists (function - | ( (Variant_runtime.Untagged (InstanceType Array) : - Variant_runtime.tag_type), - _ ) -> - true + | Variant_runtime.Payload_shape (InstanceType Array), _ -> true | _ -> false) not_typeof_clauses in @@ -893,10 +887,9 @@ let compile output_prefix = let needs_array_guard = has_object_typeof && type_has_array_case && not clauses_have_array_case in - let rec build_if_chain - (remaining_clauses : (Variant_runtime.tag_type * _) list) = + let rec build_if_chain remaining_clauses = match remaining_clauses with - | ( Variant_runtime.Untagged (InstanceType instance_type), + | ( Variant_runtime.Payload_shape (InstanceType instance_type), {J.switch_body} ) :: rest -> S.if_ diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml index 8af8c888c0..871e99e42f 100644 --- a/compiler/ml/ast_untagged_variants.ml +++ b/compiler/ml/ast_untagged_variants.ml @@ -374,15 +374,15 @@ module Dynamic_checks = struct let not x = Not x let nil = Literal Null |> tag_type let undefined = Literal Undefined |> tag_type - let object_ = Untagged ObjectType |> tag_type + let object_ = Payload_shape ObjectType |> tag_type - let function_ = Untagged FunctionType |> tag_type - let string = Untagged StringType |> tag_type - let number = Untagged IntType |> tag_type + let function_ = Payload_shape FunctionType |> tag_type + let string = Payload_shape StringType |> tag_type + let number = Payload_shape IntType |> tag_type - let bigint = Untagged BigintType |> tag_type + let bigint = Payload_shape BigintType |> tag_type - let boolean = Untagged BooleanType |> tag_type + let boolean = Payload_shape BooleanType |> tag_type let ( == ) x y = bin EqEqEq x y let ( != ) x y = bin NotEqEq x y @@ -499,7 +499,7 @@ module Dynamic_checks = struct else (* (undefiled + other) || other *) typeof e != object_ - let add_runtime_type_check ~(tag_type : tag_type) ~has_null_case + let add_runtime_type_check ~tag_type ~has_null_case ~(block_cases : block_type list) x y = let instances = Ext_list.filter_map block_cases (function @@ -507,11 +507,11 @@ module Dynamic_checks = struct | _ -> None) in match tag_type with - | Untagged + | Payload_shape ( IntType | StringType | FloatType | BigintType | BooleanType | FunctionType ) -> typeof y == x - | Untagged ObjectType -> + | Payload_shape ObjectType -> let object_case = if has_null_case then typeof y == x &&& (y != nil) else typeof y == x in @@ -522,8 +522,8 @@ module Dynamic_checks = struct in not_one_of_the_instances else object_case - | Untagged (InstanceType i) -> is_instance i y - | Untagged UnknownType -> + | Payload_shape (InstanceType i) -> is_instance i y + | Payload_shape UnknownType -> (* This should not happen because unknown must be the only non-literal case *) assert false | Literal _ -> x diff --git a/compiler/ml/variant_layout.ml b/compiler/ml/variant_layout.ml index 86013d9772..f7cb3a3ad2 100644 --- a/compiler/ml/variant_layout.ml +++ b/compiler/ml/variant_layout.ml @@ -52,7 +52,9 @@ let get_block_type ~env (cstr : Types.constructor_declaration) : block_type = report_constructor_more_than_one_arg ~loc:cstr.cd_loc ~name:(Ident.name cstr.cd_id) | Cstr_record _ -> ObjectType - | Cstr_tuple [] -> UnknownType + | Cstr_tuple [] -> + (* Nullary constructors are handled before computing a payload shape. *) + assert false let layout_from_type_variant ~(configuration : configuration) ~env (cstrs : Types.constructor_declaration list) : Variant_runtime.layout = diff --git a/compiler/ml/variant_runtime.ml b/compiler/ml/variant_runtime.ml index 1134cd75ba..d3d365c729 100644 --- a/compiler/ml/variant_runtime.ml +++ b/compiler/ml/variant_runtime.ml @@ -79,14 +79,10 @@ type literal_tag = | Null | Undefined -(* - 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 = - | Literal of literal_tag (* literal or tagged block *) - | Untagged of block_type (* untagged block *) +(** Information used to recognize a constructor during matching. A literal + identifies a constant or an object's tag; a payload shape identifies a + value represented directly by its payload. *) +type tag_type = Literal of literal_tag | Payload_shape of block_type type tag = {name: string; literal: literal_tag option} (** A constructor's name and optional explicitly declared runtime literal. *) diff --git a/compiler/ml/variant_runtime.mli b/compiler/ml/variant_runtime.mli index d30b2676ae..8f310a47b2 100644 --- a/compiler/ml/variant_runtime.mli +++ b/compiler/ml/variant_runtime.mli @@ -50,7 +50,10 @@ type literal_tag = | Null | Undefined -type tag_type = Literal of literal_tag | Untagged of block_type +(** Information used to recognize a constructor during matching. A literal + identifies a constant or an object's tag; a payload shape identifies a + value represented directly by its payload. *) +type tag_type = Literal of literal_tag | Payload_shape of block_type type tag = {name: string; literal: literal_tag option} (** A constructor's name and optional explicitly declared runtime literal. *) diff --git a/tests/ounit_tests/ounit_string_literal_tests.ml b/tests/ounit_tests/ounit_string_literal_tests.ml index 7bac4d80bc..20381fdddd 100644 --- a/tests/ounit_tests/ounit_string_literal_tests.ml +++ b/tests/ounit_tests/ounit_string_literal_tests.ml @@ -747,7 +747,7 @@ let suites = let date = Variant_runtime.Instance.Date in assert_js_global ~expected:"Date" (Js_exp_make.emit_check - (TagType (Variant_runtime.Untagged (InstanceType date)))); + (TagType (Variant_runtime.Payload_shape (InstanceType date)))); match Js_exp_make.emit_check (IsInstanceOf (date, Expr value)) with | {expression_desc = Bin (InstanceOf, argument, constructor)} -> OUnit.assert_bool "expected the original argument"