Collapse constructor identity into a kind

The Ordinary_constructor payload duplicated information already on the
description: its name field mirrored cstr_name (read only by
same_constructor, which has the whole description in hand), and its
type_path had no remaining reader once the stored layout replaced the
declaration lookups. constructor_identity becomes constructor_kind —
Ordinary_constructor | Extension_constructor of Path.t — and identity is
the pair of cstr_kind and cstr_name, or the extension's path. This also
removes the unenforced invariant that the identity's name matched
cstr_name, and makes the wrong comparison (ordinary constructors by
path, which re-exports would break) inexpressible.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01YWw5GW8t4UDEWAzoqcDMkE

Author: cristianoc

analysis/reanalyze/src/dead_value.ml

@@ -230,10 +230,10 @@ let rec collect_expr ~config ~refs ~file_deps ~cross_file ~direct_callees
       ( _,
         {
           cstr_loc = {Location.loc_start = pos_to; loc_ghost} as loc_to;
-          cstr_identity;
+          cstr_kind;
         },
         _ ) ->
-    (match cstr_identity with
+    (match cstr_kind with
     | Extension_constructor path ->
       path
       |> Dead_exception.mark_as_used ~config ~refs ~file_deps ~cross_file

compiler/ml/datarepr.ml

@@ -144,8 +144,7 @@ let constructor_descrs ty_path decl cstrs =
           cstr_existentials = existentials;
           cstr_args;
           cstr_arity = List.length cstr_args;
-          cstr_identity =
-            Ordinary_constructor {type_path = ty_path; name = cstr_name};
+          cstr_kind = Ordinary_constructor;
           cstr_layout = Some layout;
           cstr_transparent =
             !num_consts = 0 && !num_nonconsts = 1 && cstr_args <> []
@@ -201,7 +200,7 @@ let extension_descr path_ext ext =
     cstr_existentials = existentials;
     cstr_args;
     cstr_arity = List.length cstr_args;
-    cstr_identity = Extension_constructor path_ext;
+    cstr_kind = Extension_constructor path_ext;
     cstr_layout = None;
     cstr_transparent = false;
     cstr_private = ext.ext_private;

compiler/ml/env.ml

@@ -510,7 +510,7 @@ let is_ident = function
   | Pdot _ | Papply _ -> false
 
 let is_local_ext = function
-  | {cstr_identity = Extension_constructor p} -> is_ident p
+  | {cstr_kind = Extension_constructor p} -> is_ident p
   | _ -> false
 
 let diff env1 env2 =
@@ -851,7 +851,7 @@ let find_type_full path env =
       Ext_list.filter
         (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false)
         (function
-          | {cstr_identity = Extension_constructor _} -> true
+          | {cstr_kind = Extension_constructor _} -> true
           | _ -> false)
     in
 
@@ -1092,7 +1092,7 @@ let lookup_all_simple proj1 proj2 shadow ?loc lid env =
 let has_local_constraints env = not (Path_map.is_empty env.local_constraints)
 
 let cstr_shadow cstr1 cstr2 =
-  match (cstr1.cstr_identity, cstr2.cstr_identity) with
+  match (cstr1.cstr_kind, cstr2.cstr_kind) with
   | Extension_constructor _, Extension_constructor _ -> true
   | _ -> false
 
@@ -1211,7 +1211,7 @@ let lookup_all_constructors ?loc lid env =
 
 let mark_constructor usage env name desc =
   if not (is_implicit_coercion env) then
-    match desc.cstr_identity with
+    match desc.cstr_kind with
     | Extension_constructor _ -> (
       let ty_path = ty_path desc.cstr_res in
       let ty_name = Path.last ty_path in

compiler/ml/matching.ml

@@ -927,7 +927,7 @@ and split_constr cls args def k =
   let ex_pat = what_is_cases cls in
   match ex_pat.pat_desc with
   | Tpat_any -> precompile_var args cls def k
-  | Tpat_construct (_, {cstr_identity = Extension_constructor _}, _) ->
+  | Tpat_construct (_, {cstr_kind = Extension_constructor _}, _) ->
     split_naive cls args def k
   | _ -> (
     let group = get_group ex_pat in
@@ -1271,8 +1271,8 @@ let make_constr_matching p def ctx = function
       if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then
         (arg, Alias) :: argl
       else
-        match cstr.cstr_identity with
-        | Ordinary_constructor _
+        match cstr.cstr_kind with
+        | Ordinary_constructor
           when cstr.cstr_args <> []
                && Datarepr.constructor_has_optional_shape cstr ->
           let from_option =
@@ -1283,7 +1283,7 @@ let make_constr_matching p def ctx = function
             | _ -> Pval_from_option
           in
           (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl
-        | Ordinary_constructor _ ->
+        | Ordinary_constructor ->
           make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl
             ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant)
         | Extension_constructor _ ->
@@ -2005,8 +2005,8 @@ let split_cases tag_lambda_list =
     | [] -> ([], [])
     | (cstr, act) :: rem -> (
       let consts, nonconsts = split_rec rem in
-      match cstr.cstr_identity with
-      | Ordinary_constructor _ ->
+      match cstr.cstr_kind with
+      | Ordinary_constructor ->
         if cstr.cstr_args = [] then ((cstr, act) :: consts, nonconsts)
         else (consts, (cstr, act) :: nonconsts)
       | Extension_constructor _ -> assert false)
@@ -2031,9 +2031,9 @@ let get_extension_cases tag_lambda_list =
     | [] -> []
     | (cstr, act) :: rem -> (
       let nonconsts = split_rec rem in
-      match cstr.cstr_identity with
+      match cstr.cstr_kind with
       | Extension_constructor path -> (path, act) :: nonconsts
-      | Ordinary_constructor _ -> assert false)
+      | Ordinary_constructor -> assert false)
   in
   split_rec tag_lambda_list
 
@@ -2053,9 +2053,9 @@ let constructor_switch_key layout (cstr : Types.constructor_description) =
 let combine_constructor loc arg ex_pat cstr partial ctx def
     (tag_lambda_list, total1, pats) =
   let is_extension =
-    match cstr.cstr_identity with
+    match cstr.cstr_kind with
     | Extension_constructor _ -> true
-    | Ordinary_constructor _ -> false
+    | Ordinary_constructor -> false
   in
   if is_extension then
     (* Special cases for extensions *)

compiler/ml/parmatch.ml

@@ -862,9 +862,9 @@ let row_of_pat pat =
 let full_match closing env =
   match env with
   | (({pat_desc = Tpat_construct (_, c, _)} as p), _) :: _ -> (
-    match c.cstr_identity with
+    match c.cstr_kind with
     | Extension_constructor _ -> false
-    | Ordinary_constructor _ ->
+    | Ordinary_constructor ->
       List.length env
       = List.length (get_variant_constructors p.pat_env c.cstr_res))
   | (({pat_desc = Tpat_variant _} as p), _) :: _ ->
@@ -910,11 +910,10 @@ let should_extend ext env =
     | [] -> assert false
     | (p, _) :: _ -> (
       match p.pat_desc with
-      | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, _) ->
+      | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, _) ->
         let path = get_type_path p.pat_type p.pat_env in
         Path.same path ext
-      | Tpat_construct (_, {cstr_identity = Extension_constructor _}, _) ->
-        false
+      | Tpat_construct (_, {cstr_kind = Extension_constructor _}, _) -> false
       | Tpat_constant _ | Tpat_tuple _ | Tpat_variant _ | Tpat_record _
       | Tpat_array _ ->
         false
@@ -987,7 +986,7 @@ let complete_constrs p seen_constrs =
 
 let build_other_constrs env p =
   match p.pat_desc with
-  | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, _) ->
+  | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, _) ->
     let get_constr = function
       | {pat_desc = Tpat_construct (_, c, _)} -> c
       | _ -> fatal_error "Parmatch.get_constr"
@@ -1015,10 +1014,7 @@ let some_other_tag = "<some other tag>"
 
 let build_other ext env : Typedtree.pattern =
   match env with
-  | ( {
-        pat_desc =
-          Tpat_construct (lid, {cstr_identity = Extension_constructor _}, _);
-      },
+  | ( {pat_desc = Tpat_construct (lid, {cstr_kind = Extension_constructor _}, _)},
       _ )
     :: _ ->
     (* let c = {c with cstr_name = "*extension*"} in *)
@@ -2141,15 +2137,15 @@ let extendable_path path =
 
 let rec collect_paths_from_pat r p =
   match p.pat_desc with
-  | Tpat_construct (_, {cstr_identity = Ordinary_constructor _}, ps) ->
+  | Tpat_construct (_, {cstr_kind = Ordinary_constructor}, ps) ->
     let path = get_type_path p.pat_type p.pat_env in
     List.fold_left collect_paths_from_pat
       (if extendable_path path then add_path path r else r)
       ps
   | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> r
   | Tpat_tuple ps
   | Tpat_array ps
-  | Tpat_construct (_, {cstr_identity = Extension_constructor _}, ps) ->
+  | Tpat_construct (_, {cstr_kind = Extension_constructor _}, ps) ->
     List.fold_left collect_paths_from_pat r ps
   | Tpat_record (lps, _, _rest) ->
     List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps

compiler/ml/rec_check.ml

@@ -264,7 +264,7 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
   | Texp_array exprs -> Use.guard (list expression env exprs)
   | Texp_construct (_, desc, exprs) ->
     let access_constructor =
-      match desc.cstr_identity with
+      match desc.cstr_kind with
       | Extension_constructor pth -> Use.inspect (path env pth)
       | _ -> Use.empty
     in

compiler/ml/translcore.ml

@@ -537,18 +537,14 @@ let transl_primitive_application loc prim env ty args =
               {
                 exp_desc =
                   Texp_construct
-                    ( _,
-                      {cstr_identity = Ordinary_constructor _; cstr_args = []},
-                      _ );
+                    (_, {cstr_kind = Ordinary_constructor; cstr_args = []}, _);
               };
             ]
           | [
               {
                 exp_desc =
                   Texp_construct
-                    ( _,
-                      {cstr_identity = Ordinary_constructor _; cstr_args = []},
-                      _ );
+                    (_, {cstr_kind = Ordinary_constructor; cstr_args = []}, _);
               };
               _;
             ]
@@ -778,16 +774,16 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
       | [x] -> x
       | _ -> assert false
     else
-      match cstr.cstr_identity with
-      | Ordinary_constructor _ when cstr.cstr_args = [] ->
+      match cstr.cstr_kind with
+      | Ordinary_constructor when cstr.cstr_args = [] ->
         Lconst
           (Const_pointer
              (if Datarepr.constructor_has_optional_shape cstr then Pt_shape_none
               else
                 Pt_constructor
                   (Ast_untagged_variants.constructor_tag ~name:cstr.cstr_name
                      cstr.cstr_attributes)))
-      | Ordinary_constructor _ -> (
+      | Ordinary_constructor -> (
         let runtime =
           Ast_untagged_variants.block_runtime ~name:cstr.cstr_name
             cstr.cstr_attributes

compiler/ml/typecore.ml

@@ -3450,7 +3450,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp
           };
         ] ->
       let path =
-        match (Typetexp.find_constructor env lid.loc lid.txt).cstr_identity with
+        match (Typetexp.find_constructor env lid.loc lid.txt).cstr_kind with
         | Extension_constructor path -> path
         | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor))
       in

compiler/ml/typedecl.ml

@@ -1690,7 +1690,7 @@ let transl_extension_constructor env type_path type_params typext_params priv
       | Private, Public -> raise (Error (lid.loc, Rebind_private lid.txt))
       | _ -> ());
       let path =
-        match cdescr.cstr_identity with
+        match cdescr.cstr_kind with
         | Extension_constructor path -> path
         | _ -> assert false
       in

compiler/ml/types.ml

@@ -250,7 +250,7 @@ type constructor_description = {
   cstr_existentials: type_expr list; (* list of existentials *)
   cstr_args: type_expr list; (* Type of the arguments *)
   cstr_arity: int; (* Number of arguments *)
-  cstr_identity: constructor_identity; (* Semantic identity *)
+  cstr_kind: constructor_kind;
   cstr_layout: Variant_runtime.variant_layout option;
       (* Runtime layout of the declaring variant; None for extension
          constructors *)
@@ -264,28 +264,27 @@ type constructor_description = {
   cstr_inlined: type_declaration option;
 }
 
-and constructor_identity =
-  | Ordinary_constructor of {type_path: Path.t; name: string}
-    (* Constructor introduced by a variant type declaration. The path is
-         the path of the declaring type as written, so a re-exported variant
-         (type u = M.t = A | B) yields descriptions carrying the
-         re-exporting type's path. *)
-  | Extension_constructor of Path.t (* Extension constructor *)
+and constructor_kind =
+  | Ordinary_constructor
+    (* Constructor introduced by a variant type declaration; identified
+         within its variant by [cstr_name] *)
+  | Extension_constructor of Path.t
+(* Extension constructor, identified by its own path since extension
+         constructors can be rebound *)
 
 (* Whether two constructor descriptions denote the same constructor of a
    common scrutinee type. Because a re-exported variant mints descriptions
    with a different type path, ordinary constructors are compared by name
    only; the shared scrutinee type makes the name unambiguous. Not a
    general-purpose identity test across unrelated types. *)
 let same_constructor c1 c2 =
-  match (c1.cstr_identity, c2.cstr_identity) with
-  | Ordinary_constructor {name = n1}, Ordinary_constructor {name = n2} ->
-    n1 = n2
+  match (c1.cstr_kind, c2.cstr_kind) with
+  | Ordinary_constructor, Ordinary_constructor -> c1.cstr_name = c2.cstr_name
   | Extension_constructor p1, Extension_constructor p2 -> Path.same p1 p2
-  | (Ordinary_constructor _ | Extension_constructor _), _ -> false
+  | (Ordinary_constructor | Extension_constructor _), _ -> false
 
 let may_equal_constr c1 c2 =
-  match (c1.cstr_identity, c2.cstr_identity) with
+  match (c1.cstr_kind, c2.cstr_kind) with
   | Extension_constructor _, Extension_constructor _ ->
     (* extension constructors may be rebound, so paths cannot disprove
        equality; arity can *)