Fix constant folding of overlapping unboxed variant matches

CHANGELOG.md

@@ -36,6 +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. 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

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) ->

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

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 -> (

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;
-         }) ->
-    Some {name; tag_type = Some (Untagged block_type)}
-  | Switch_constructor (Block {runtime = {untagged = false; tag}}) ->
+  | Switch_constructor (Block (Untagged {tag = {name}; block_type})) ->
+    Some {name; tag_type = Some (Payload_shape block_type)}
+  | 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))
@@ -859,7 +851,7 @@ let compile output_prefix =
       E.emit_check check
     in
     let tag_is_not_typeof = function
-      | Variant_runtime.Untagged (InstanceType _) -> true
+      | Variant_runtime.Payload_shape (InstanceType _) -> true
       | _ -> false
     in
     let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in
@@ -870,14 +862,14 @@ let compile output_prefix =
       let has_object_typeof =
         List.exists
           (function
-            | Variant_runtime.Untagged ObjectType, _ -> true
+            | Variant_runtime.Payload_shape ObjectType, _ -> true
             | _ -> false)
           typeof_clauses
       in
       let clauses_have_array_case =
         List.exists
           (function
-            | Variant_runtime.Untagged (InstanceType Array), _ -> true
+            | Variant_runtime.Payload_shape (InstanceType Array), _ -> true
             | _ -> false)
           not_typeof_clauses
       in
@@ -897,7 +889,7 @@ let compile output_prefix =
       in
       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_

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)

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})
@@ -371,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
@@ -504,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
@@ -519,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

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