Make @unboxed apply to a whole variant only

changes/remove-unboxed-on-constructors.breaking.md

@@ -0,0 +1 @@
+- `@unboxed` applies to a whole variant and can no longer be written on a constructor. Write `@unboxed type t = ...` instead. A constructor whose payload is an inline record with one field became that record object, while `@unboxed` on its type makes the value the field: give the record type a name to keep the object.

compiler/ml/UntaggedVariants.md

@@ -20,24 +20,35 @@ directory is named.
 
 ### 1. Declaration
 
-`@unboxed` and `@tag(...)` on a variant type are copied onto every
-constructor. `@unboxed` on a single constructor of an ordinary variant makes
-that constructor untagged and leaves the others tagged:
+`@unboxed` on a variant type makes the whole variant untagged: every case with
+a payload is represented by its payload. `@tag(...)` on the type is copied
+onto every constructor. A constructor cannot have its own `@unboxed`: it would
+mix tagged and untagged cases in one variant, and is an error telling to write
+it on the type. For a constructor whose payload is an inline record with one
+field, `@unboxed` on the type makes the value that field (the legacy unboxed
+representation), so the error also tells to give the record type a name to
+keep the record object.
 
 | Declaration | Value | JavaScript |
 | --- | --- | --- |
-| `type mixed = \| @unboxed MA(int) \| MB({x: int}) \| MC` | `MA(3)` | `3` |
-| | `MB({x: 1})` | `{TAG: "MB", x: 1}` |
-| | `MC` | `"MC"` |
+| `@unboxed type whole = WA(int) \| WB({x: int}) \| WC` | `WA(3)` | `3` |
+| | `WB({x: 1})` | `{x: 1}` |
+| | `WC` | `"WC"` |
+
+| Declaration | Error | Fixture |
+| --- | --- | --- |
+| `type t = \| @unboxed A(int) \| B({x: int}) \| C` | @unboxed applies to a whole variant: write it on the type, ... | `unboxed_on_constructor.res` |
+| `type t = \| @unboxed A({x: int})` | the same, and how to keep the record object | `unboxed_on_single_field_record_constructor.res` |
 
 The layout of a declaration is computed once, after its recursive group is in
 the environment, and stored on the declaration.
 
-- Implementation: `typedecl.ml` (`copy_tag_attr_from_decl` in
-  `transl_declaration`; the layout pass in `transl_type_decl`),
-  `variant_layout.ml:layout_from_type_variant`.
-- Tests: `spec_test` rule 1.
-- Shaped by #7320 (recursive groups), #8579 (layout stored once).
+- Implementation: `typedecl.ml` (the constructor check and
+  `copy_tag_attr_from_decl` in `transl_declaration`; the layout pass in
+  `transl_type_decl`), `variant_layout.ml:layout_from_type_variant`.
+- Tests: `spec_test` rule 1; the fixtures above.
+- Shaped by #7320 (recursive groups), #8579 (layout stored once), #9020 and
+  #9038 (constructor-level `@unboxed` removed).
 
 ### 2. Representation
 

compiler/ml/ast_untagged_variants.ml

@@ -20,6 +20,7 @@ type error =
   | InvalidVariantTagAnnotation
   | InvalidUntaggedVariantDefinition of untagged_error
   | TagFieldNameConflict of string * string * string
+  | UnboxedOnConstructor of {constructor: string; single_field_record: bool}
 exception Error of Location.t * error
 
 let report_error ppf =
@@ -71,6 +72,18 @@ let report_error ppf =
        value of inline record field \"%s\". Use a different @tag name or \
        rename the field."
       constructor_name runtime_value field_name
+  | UnboxedOnConstructor {constructor; single_field_record} ->
+    fprintf ppf
+      "@@unboxed applies to a whole variant: write it on the type, as in \
+       `@@unboxed type t = ...`, instead of on constructor %s."
+      constructor;
+    if single_field_record then
+      fprintf ppf
+        " For a constructor whose payload is an inline record with one field, \
+         `@@unboxed type t = %s({...})` makes the value that field. To keep \
+         the record object, give the record type a name: `@@unboxed type t = \
+         %s(r)`."
+        constructor constructor
 
 (*
   Type of the runtime representation of a tag.
@@ -91,14 +104,6 @@ let untagged = "unboxed"
 let has_untagged (attrs : Parsetree.attributes) =
   Ext_list.exists attrs (function {txt}, _ -> txt = untagged)
 
-let process_untagged (attrs : Parsetree.attributes) =
-  let st = ref false in
-  Ext_list.iter attrs (fun ({txt}, _) ->
-      match txt with
-      | "unboxed" -> st := true
-      | _ -> ());
-  !st
-
 let runtime_tag_of_parsetree ~loc = function
   | Parsetree.Pct_string s -> String (String_literal.string_semantic s)
   | Pct_int source -> (
@@ -211,7 +216,7 @@ let is_nullary_variant (x : Types.constructor_arguments) =
 (* A literal's JavaScript value, which a [switch] compares with [===]. Ints
    are emitted as 32-bit numbers, so [1], [1.0] and [4294967297] are one
    number, while [1n] is a bigint. *)
-let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
+let check_invariant ~(consts : (Location.t * tag) list)
     ~(blocks : (Location.t * block) list) =
   let module String_set = Set.Make (String) in
   let module String_map = Map.Make (String) in
@@ -297,61 +302,40 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
 
   Ext_list.rev_iter consts (fun (loc, literal) ->
       check_literal ~is_const:true ~loc literal);
-  (* A tagged block is told apart from the others by its tag; an untagged one
-     is its payload, whatever its [@as] *)
+  (* The blocks of a variant are all tagged or, when the type is [@unboxed],
+     all untagged. A tagged block is told apart from the others by its tag; an
+     untagged one by the kind of its payload, whatever its [@as]. *)
   Ext_list.rev_iter blocks (fun (loc, block) ->
       match block with
       | Tagged {tag} -> check_literal ~is_const:false ~loc tag
-      | Untagged _ -> ());
-  (* The payload kinds are checked as soon as one case is untagged, even when
-     the type itself is not [@unboxed] *)
-  let has_untagged_block =
-    List.exists
-      (function
-        | _, Untagged _ -> true
-        | _, Tagged _ -> false)
-      blocks
-  in
-  if is_untagged_def || has_untagged_block then (
-    (* Tagged blocks are objects with a tag field: together one object case *)
-    if
-      List.exists
-        (function
-          | _, Tagged _ -> true
-          | _, Untagged _ -> false)
-        blocks
-    then incr object_types;
-    Ext_list.rev_iter blocks (fun (loc, block) ->
-        match block with
-        | Untagged {tag; block_type} ->
-          (match block_type with
-          | UnknownType -> incr unknown_types
-          | ObjectType -> incr object_types
-          | InstanceType i ->
-            let count =
-              Hashtbl.find_opt instance_types i |> Option.value ~default:0
-            in
-            Hashtbl.replace instance_types i (count + 1)
-          | FunctionType -> incr function_types
-          | IntType | FloatType -> incr number_types
-          | BigintType -> incr bigint_types
-          | BooleanType ->
-            (* Literal cases are matched before payload cases, so a boolean
+      | Untagged {tag; block_type} ->
+        (match block_type with
+        | UnknownType -> incr unknown_types
+        | ObjectType -> incr object_types
+        | InstanceType i ->
+          let count =
+            Hashtbl.find_opt instance_types i |> Option.value ~default:0
+          in
+          Hashtbl.replace instance_types i (count + 1)
+        | FunctionType -> incr function_types
+        | IntType | FloatType -> incr number_types
+        | BigintType -> incr bigint_types
+        | BooleanType ->
+          (* Literal cases are matched before payload cases, so a boolean
                payload only receives the booleans that are not literal cases.
                A partial overlap is allowed, like for strings and numbers. *)
-            if
-              String_map.mem "true" !nonstring_literals_consts
-              && String_map.mem "false" !nonstring_literals_consts
-            then
-              raise
-                (Error
-                   ( loc,
-                     InvalidUntaggedVariantDefinition
-                       (UnreachableBoolean tag.name) ));
-            incr boolean_types
-          | StringType -> incr string_types);
-          invariant loc tag.name
-        | Tagged _ -> ()))
+          if
+            String_map.mem "true" !nonstring_literals_consts
+            && String_map.mem "false" !nonstring_literals_consts
+          then
+            raise
+              (Error
+                 ( loc,
+                   InvalidUntaggedVariantDefinition
+                     (UnreachableBoolean tag.name) ));
+          incr boolean_types
+        | StringType -> incr string_types);
+        invariant loc tag.name)
 
 let get_cstr_loc_tag (cstr : Types.constructor_declaration) =
   (cstr.cd_loc, {name = Ident.name cstr.cd_id; literal = cstr.cd_runtime_tag})

compiler/ml/printtyp.ml

@@ -1604,7 +1604,7 @@ let print_variant_configuration_issue ppf
     let print_unboxed_status ppf unboxed name =
       fprintf ppf "@ - Variant @{<info>%s@} is @{<error>%s@}unboxed."
         (Path.name name)
-        (if unboxed then "not " else "")
+        (if unboxed then "" else "not ")
     in
     print_unboxed_status ppf left_unboxed left_variant_name;
     print_unboxed_status ppf right_unboxed right_variant_name;

compiler/ml/typedecl.ml

@@ -472,10 +472,31 @@ let transl_declaration ~type_record_as_object env sdecl id =
             raise (Error (sdecl.ptype_loc, Duplicate_constructor name));
           all_constrs := String_set.add name !all_constrs)
         scstrs;
+      (* [@unboxed] applies to the whole variant, so a constructor cannot have
+         its own *)
+      List.iter
+        (fun {pcd_name = {txt = constructor}; pcd_args; pcd_attributes} ->
+          match
+            Ext_list.find_first pcd_attributes (fun ({txt}, _) ->
+                txt = Ast_untagged_variants.untagged)
+          with
+          | Some ({loc}, _) ->
+            raise
+              (Ast_untagged_variants.Error
+                 ( loc,
+                   UnboxedOnConstructor
+                     {
+                       constructor;
+                       single_field_record =
+                         (match pcd_args with
+                         | Pcstr_record [_] -> true
+                         | Pcstr_record _ | Pcstr_tuple _ -> false);
+                     } ))
+          | None -> ())
+        scstrs;
       let copy_tag_attr_from_decl attr =
         let tag_attrs =
-          Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) ->
-              txt = "tag" || txt = Ast_untagged_variants.untagged)
+          Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> txt = "tag")
         in
         if tag_attrs = [] then attr else tag_attrs @ attr
       in

compiler/ml/variant_coercion.ml

@@ -198,8 +198,8 @@ let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc
     ~right_loc ~(left_attributes : Parsetree.attributes)
     ~(right_attributes : Parsetree.attributes) =
   (match
-     ( Ast_untagged_variants.process_untagged left_attributes,
-       Ast_untagged_variants.process_untagged right_attributes )
+     ( Ast_untagged_variants.has_untagged left_attributes,
+       Ast_untagged_variants.has_untagged right_attributes )
    with
   | true, true | false, false -> ()
   | left, _right ->

compiler/ml/variant_layout.ml

@@ -61,7 +61,7 @@ let layout_from_type_variant ~(configuration : configuration) ~env
   let get_block (cstr : Types.constructor_declaration) : block =
     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
+    if configuration.unboxed then
       Untagged {tag; block_type = get_block_type ~env cstr}
     else Tagged {tag; tag_name}
   in
@@ -81,7 +81,7 @@ let layout_from_type_variant ~(configuration : configuration) ~env
         | Constant tag -> ((loc, tag) :: consts, blocks)
         | Block block -> (consts, (loc, block) :: blocks))
   in
-  check_invariant ~is_untagged_def:configuration.unboxed ~consts ~blocks;
+  check_invariant ~consts ~blocks;
   let constructors =
     Array.of_list
       (List.map (fun (_, constructor) -> constructor) located_constructors)

tests/build_tests/super_errors/expected/unboxed_on_constructor.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/unboxed_on_constructor.res:1:12-19
+
+  1 │ type t = | @unboxed A(int) | B({x: int}) | C
+  2 │ 
+
+  @unboxed applies to a whole variant: write it on the type, as in `@unboxed type t = ...`, instead of on constructor A.

tests/build_tests/super_errors/expected/unboxed_on_single_field_record_constructor.res.expected

@@ -0,0 +1,8 @@
+
+  We've found a bug for you!
+  /.../fixtures/unboxed_on_single_field_record_constructor.res:1:12-19
+
+  1 │ type t = | @unboxed A({x: int})
+  2 │ 
+
+  @unboxed applies to a whole variant: write it on the type, as in `@unboxed type t = ...`, instead of on constructor A. For a constructor whose payload is an inline record with one field, `@unboxed type t = A({...})` makes the value that field. To keep the record object, give the record type a name: `@unboxed type t = A(r)`.

tests/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected

@@ -10,7 +10,7 @@
   Type x is not a subtype of y 
 
   The variants have different @unboxed configurations.
-  - Variant x is not unboxed.
-  - Variant y is unboxed.
+  - Variant x is unboxed.
+  - Variant y is not unboxed.
 
   Fix this by making sure the variants either both have, or don't have, the @unboxed attribute.

tests/build_tests/super_errors/fixtures/unboxed_on_constructor.res

@@ -0,0 +1 @@
+type t = | @unboxed A(int) | B({x: int}) | C

tests/build_tests/super_errors/fixtures/unboxed_on_single_field_record_constructor.res

@@ -0,0 +1 @@
+type t = | @unboxed A({x: int})

tests/tests/src/record_extension_test.res

@@ -31,7 +31,7 @@ describe(__LOC__, () => {
 })
 
 /* Record_unboxed */
-type t1 = | @unboxed A({x: int})
+@unboxed type t1 = A({x: int})
 
 /* Record_inlined */
 type t2 =