Consume the stored variant layout everywhere

Constructor descriptions now carry their declaring variant's layout,
minted in datarepr from the declaration, and every consumer reads it
instead of re-deriving representation facts:

- Matching takes the layout straight from the constructor description;
  the per-switch type resolution and the sw_layout plumbing are gone,
  and sw_dispatch is the layout's precomputed dispatch.
- Translcore counts payload constructors from the stored layout instead
  of looking the declaration up in the environment.
- Parmatch reads a constructor's untagged block type from the stored
  layout instead of re-resolving the declaration.

With typedecl the only remaining layout computer, the derivation
(get_block_type and friends) moves to a new Variant_layout module above
Ctype, and the Obj.magic forward references in Ast_untagged_variants are
deleted: typing a declaration now determines its representation once,
and it is never revisited.

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

Author: cristianoc

compiler/ml/ast_untagged_variants.ml

@@ -118,6 +118,7 @@ type constructor_case = Variant_runtime.constructor_case =
 type variant_layout = Variant_runtime.variant_layout = {
   constructors: constructor_case array;
   constructors_by_name: (int * constructor_case) Map_string.t;
+  dispatch: Variant_runtime.variant_dispatch;
 }
 (** Canonical runtime layout in source-constructor order. *)
 
@@ -132,42 +133,6 @@ type variant_dispatch = Variant_runtime.variant_dispatch = {
 (** The whole-variant information needed to choose a JavaScript dispatch
     strategy. Constructor identity is carried by each switch arm instead. *)
 
-let dispatch_from_layout layout =
-  let tag_name = ref None in
-  let block_types = ref [] in
-  let literal_tags = ref [] in
-  let has_null = ref false in
-  let has_undefined = ref false in
-  let has_other_literal = ref false in
-  Array.iter
-    (function
-      | Constant {name; tag_type} -> (
-        let tag =
-          match tag_type with
-          | Some tag -> tag
-          | None -> String name
-        in
-        literal_tags := tag :: !literal_tags;
-        match tag with
-        | Null -> has_null := true
-        | Undefined -> has_undefined := true
-        | String _ | Int _ | Float _ | BigInt _ | Bool _ | Untagged _ ->
-          has_other_literal := true)
-      | Block {runtime = {tag_name = constructor_tag_name}; block_type} -> (
-        if !tag_name = None then tag_name := constructor_tag_name;
-        match block_type with
-        | Some block_type -> block_types := block_type :: !block_types
-        | None -> ()))
-    layout.constructors;
-  {
-    tag_name = !tag_name;
-    block_types = !block_types;
-    literal_tags = !literal_tags;
-    has_null = !has_null;
-    has_undefined = !has_undefined;
-    has_other_literal = !has_other_literal;
-  }
-
 let constructor_by_name layout name =
   snd (Map_string.find_exn layout.constructors_by_name name)
 
@@ -210,16 +175,6 @@ let process_untagged (attrs : Parsetree.attributes) =
       | _ -> ());
   !st
 
-(* Filled in by [Typedecl] to break the module cycle through [Ctype];
-   installed at module initialization of the typing layer, so they are set
-   before any declaration is typed. *)
-let extract_concrete_typedecl :
-    (Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration) ref =
-  ref (Obj.magic ())
-
-let expand_head : (Env.t -> Types.type_expr -> Types.type_expr) ref =
-  ref (Obj.magic ())
-
 let process_tag_type (attrs : Parsetree.attributes) =
   let st : tag_type option ref = ref None in
   Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) ->
@@ -301,57 +256,6 @@ let type_to_instanceof_backed_obj (t : Types.type_expr) =
     | _ -> None)
   | _ -> None
 
-let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option =
-  (* First check the original (unexpanded) type for typed arrays and other instance types *)
-  match type_to_instanceof_backed_obj t with
-  | Some instance_type -> Some (InstanceType instance_type)
-  | None -> (
-    (* If original type didn't match, expand and try standard checks *)
-    let expanded_t = !expand_head env t in
-    match expanded_t with
-    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string ->
-      Some StringType
-    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int ->
-      Some IntType
-    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float ->
-      Some FloatType
-    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint ->
-      Some BigintType
-    | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool ->
-      Some BooleanType
-    | {desc = Tarrow _} -> Some FunctionType
-    | {desc = Tconstr _} as expanded_t when type_is_builtin_object expanded_t ->
-      Some ObjectType
-    | {desc = Tconstr _} as expanded_t
-      when type_to_instanceof_backed_obj expanded_t |> Option.is_some -> (
-      match type_to_instanceof_backed_obj expanded_t with
-      | None -> None
-      | Some instance_type -> Some (InstanceType instance_type))
-    | {desc = Ttuple _} -> Some (InstanceType Array)
-    | _ -> None)
-
-let get_block_type ~env (cstr : Types.constructor_declaration) :
-    block_type option =
-  match (process_untagged cstr.cd_attributes, cstr.cd_args) with
-  | false, _ -> None
-  | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some
-    ->
-    get_block_type_from_typ ~env t
-  | true, Cstr_tuple [ty] -> (
-    let default = Some UnknownType in
-    match !extract_concrete_typedecl env ty with
-    | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default
-    | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType
-    | _ -> default
-    | exception _ -> default)
-  | true, Cstr_tuple (_ :: _ :: _) ->
-    (* C(_, _) with at least 2 args is an object *)
-    Some ObjectType
-  | true, Cstr_record _ ->
-    (* inline record is an object *)
-    Some ObjectType
-  | true, _ -> None (* TODO: add restrictions here *)
-
 let process_tag_name (attrs : Parsetree.attributes) =
   let st = ref None in
   Ext_list.iter attrs (fun ({txt; loc}, payload) ->
@@ -485,61 +389,6 @@ let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list)
 let get_cstr_loc_tag (cstr : Types.constructor_declaration) =
   (cstr.cd_loc, constructor_tag ~name:(Ident.name cstr.cd_id) cstr.cd_attributes)
 
-let constructor_declaration_from_constructor_description ~env
-    (cd : Types.constructor_description) : Types.constructor_declaration option
-    =
-  match cd.cstr_res.desc with
-  | Tconstr (path, _, _) -> (
-    match Env.find_type path env with
-    | {type_kind = Type_variant (cstrs, _)} ->
-      Ext_list.find_opt cstrs (fun cstr ->
-          if cstr.cd_id.name = cd.cstr_name then Some cstr else None)
-    | _ -> None)
-  | _ -> None
-
-let layout_from_type_variant ?(is_untagged_def = false) ~env
-    (cstrs : Types.constructor_declaration list) =
-  let get_block (cstr : Types.constructor_declaration) : block =
-    {
-      runtime = block_runtime ~name:(Ident.name cstr.cd_id) cstr.cd_attributes;
-      block_type = get_block_type ~env cstr;
-    }
-  in
-  let located_constructors =
-    List.map
-      (fun (cstr : Types.constructor_declaration) ->
-        if is_nullary_variant cstr.cd_args then
-          let loc, tag = get_cstr_loc_tag cstr in
-          (loc, Constant tag)
-        else (cstr.cd_loc, Block (get_block cstr)))
-      cstrs
-  in
-  let consts, blocks =
-    Ext_list.fold_left located_constructors ([], [])
-      (fun (consts, blocks) (loc, constructor) ->
-        match constructor with
-        | Constant tag -> ((loc, tag) :: consts, blocks)
-        | Block block -> (consts, (loc, block) :: blocks))
-  in
-  check_invariant ~is_untagged_def ~consts ~blocks;
-  let constructors =
-    Array.of_list
-      (List.map (fun (_, constructor) -> constructor) located_constructors)
-  in
-  let constructors_by_name =
-    let _, constructors_by_name =
-      List.fold_left2
-        (fun (index, constructors_by_name)
-             (cstr : Types.constructor_declaration) (_, constructor) ->
-          ( index + 1,
-            Map_string.add constructors_by_name (Ident.name cstr.cd_id)
-              (index, constructor) ))
-        (0, Map_string.empty) cstrs located_constructors
-    in
-    constructors_by_name
-  in
-  Some {constructors; constructors_by_name}
-
 let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) =
   List.iter
     (fun (cstr : Types.constructor_declaration) ->
@@ -573,8 +422,6 @@ let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) =
 
 let has_undefined_literal attrs = process_tag_type attrs = Some Undefined
 
-let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType
-
 module Dynamic_checks = struct
   type op = EqEqEq | NotEqEq | Or | And
   type 'a t =

compiler/ml/datarepr.ml

@@ -101,6 +101,11 @@ let constructor_has_optional_shape
   List.exists (fun (x, _) -> x.txt = internal_optional) attrs
 
 let constructor_descrs ty_path decl cstrs =
+  let layout =
+    match decl.type_kind with
+    | Type_variant (_, layout) -> layout
+    | Type_abstract | Type_record _ | Type_open -> assert false
+  in
   let ty_res = newgenconstr ty_path decl.type_params in
   let num_consts = ref 0 and num_nonconsts = ref 0 in
   List.iter
@@ -141,6 +146,7 @@ let constructor_descrs ty_path decl cstrs =
           cstr_arity = List.length cstr_args;
           cstr_identity =
             Ordinary_constructor {type_path = ty_path; name = cstr_name};
+          cstr_layout = Some layout;
           cstr_transparent =
             !num_consts = 0 && !num_nonconsts = 1 && cstr_args <> []
             && List.exists
@@ -196,6 +202,7 @@ let extension_descr path_ext ext =
     cstr_args;
     cstr_arity = List.length cstr_args;
     cstr_identity = Extension_constructor path_ext;
+    cstr_layout = None;
     cstr_transparent = false;
     cstr_private = ext.ext_private;
     cstr_generalized = ext.ext_ret_type <> None;

compiler/ml/matching.ml

@@ -2050,7 +2050,7 @@ let constructor_switch_key layout (cstr : Types.constructor_description) =
   Switch_constructor
     (Ast_untagged_variants.constructor_by_name layout cstr.cstr_name)
 
-let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def
+let combine_constructor loc arg ex_pat cstr partial ctx def
     (tag_lambda_list, total1, pats) =
   let is_extension =
     match cstr.cstr_identity with
@@ -2088,7 +2088,7 @@ let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def
   else
     (* Regular concrete type *)
     let layout =
-      match sw_layout with
+      match cstr.cstr_layout with
       | Some layout -> layout
       | None -> assert false
     in
@@ -2165,9 +2165,7 @@ let combine_constructor sw_layout loc arg ex_pat cstr partial ctx def
               sw_blocks_full = List.length nonconsts >= num_nonconsts;
               sw_blocks = nonconsts;
               sw_failaction = fail_opt;
-              sw_dispatch =
-                Switch_variant
-                  (Ast_untagged_variants.dispatch_from_layout layout);
+              sw_dispatch = Switch_variant layout.dispatch;
             }
           in
           let hs, sw = share_actions_sw sw in
@@ -2457,24 +2455,6 @@ let arg_to_var arg cls =
     let v = name_pattern "match" cls in
     (v, Lvar v)
 
-(* Resolve the canonical variant layout of a constructor pattern's type,
-   following manifest chains to the declaration *)
-let layout_from_construct_pattern (pat : pattern) =
-  let rec resolve_path (path : Path.t) =
-    match Env.find_type path pat.pat_env with
-    | {type_kind = Type_variant (cstrs, _)} ->
-      Ast_untagged_variants.layout_from_type_variant ~env:pat.pat_env cstrs
-    | {type_kind = Type_abstract; type_manifest = Some t} -> (
-      match (Ctype.unalias t).desc with
-      | Tconstr (pathn, _, _) -> resolve_path pathn
-      | _ -> None)
-    | {type_kind = Type_abstract; type_manifest = None} -> None
-    | {type_kind = Type_record _ | Type_open (* Exceptions *)} -> None
-  in
-  match (Btype.repr pat.pat_type).desc with
-  | Tconstr (path, _, _) -> resolve_path path
-  | _ -> assert false
-
 (*
   The main compilation function.
    Input:
@@ -2545,11 +2525,10 @@ and do_compile_matching repr partial ctx arg pmh =
         (combine_constant pat.pat_loc arg cst partial)
         ctx pm
     | Tpat_construct (_, cstr, _) ->
-      let sw_layout = layout_from_construct_pattern pat in
       compile_test
         (compile_match repr partial)
         partial divide_constructor
-        (combine_constructor sw_layout pat.pat_loc arg pat cstr partial)
+        (combine_constructor pat.pat_loc arg pat cstr partial)
         ctx pm
     | Tpat_array _ ->
       compile_test

compiler/ml/parmatch.ml

@@ -560,23 +560,18 @@ let all_record_args lbls =
                 _,
                 [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] )
             when lbl_is_optional () -> (
-            let cdecl =
-              Ast_untagged_variants
-              .constructor_declaration_from_constructor_description
-                ~env:pat.pat_env cd
-            in
-            match cdecl with
+            match cd.cstr_layout with
             | None -> x
-            | Some cstr -> (
+            | Some layout -> (
               match
-                Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr
+                Ast_untagged_variants.constructor_by_name layout cd.cstr_name
               with
-              | Some block_type
+              | Block {block_type = Some block_type}
                 when not
                        (Ast_untagged_variants.block_type_can_be_undefined
                           block_type) ->
                 (id, lbl, pat_construct, o)
-              | _ -> x))
+              | Constant _ | Block _ -> x))
           | _ -> x
         in
         t.(lbl.lbl_pos) <- x)

compiler/ml/translcore.ml

@@ -36,18 +36,16 @@ let transl_module =
 
 (* Number of payload-carrying constructors of the variant declaring
    [cstr]; part of the runtime representation of its blocks *)
-let num_nonconst_constructors env (cstr : Types.constructor_description) =
-  match cstr.cstr_identity with
-  | Ordinary_constructor {type_path} -> (
-    match (Env.find_type type_path env).type_kind with
-    | Type_variant (cstrs, _) ->
-      List.length
-        (List.filter
-           (fun (cd : Types.constructor_declaration) ->
-             cd.cd_args <> Cstr_tuple [])
-           cstrs)
-    | _ -> assert false)
-  | Extension_constructor _ -> assert false
+let num_nonconst_constructors (cstr : Types.constructor_description) =
+  match cstr.cstr_layout with
+  | Some layout ->
+    Array.fold_left
+      (fun n (case : Variant_runtime.constructor_case) ->
+        match case with
+        | Block _ -> n + 1
+        | Constant _ -> n)
+      0 layout.constructors
+  | None -> assert false
 
 (* Compile an exception/extension definition *)
 
@@ -812,7 +810,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda =
               Blk_constructor
                 {
                   name = cstr.cstr_name;
-                  num_nonconst = num_nonconst_constructors e.exp_env cstr;
+                  num_nonconst = num_nonconst_constructors cstr;
                   runtime;
                 }
           in

compiler/ml/typedecl.ml

@@ -22,11 +22,6 @@ open Primitive
 open Types
 open Typetexp
 
-let () =
-  Ast_untagged_variants.extract_concrete_typedecl :=
-    Ctype.extract_concrete_typedecl
-let () = Ast_untagged_variants.expand_head := Ctype.expand_head
-
 type error =
   | Repeated_parameter
   | Duplicate_constructor of string
@@ -1593,12 +1588,8 @@ let transl_type_decl env rec_flag sdecl_list =
             Ast_untagged_variants.has_untagged decl.type_attributes
           in
           let layout =
-            match
-              Ast_untagged_variants.layout_from_type_variant ~is_untagged_def
-                ~env:newenv cstrs
-            with
-            | Some layout -> layout
-            | None -> assert false
+            Variant_layout.layout_from_type_variant ~is_untagged_def ~env:newenv
+              cstrs
           in
           (id, {decl with type_kind = Type_variant (cstrs, layout)})
         | Type_abstract | Type_record _ | Type_open -> (id, decl))

compiler/ml/types.ml

@@ -251,6 +251,9 @@ type constructor_description = {
   cstr_args: type_expr list; (* Type of the arguments *)
   cstr_arity: int; (* Number of arguments *)
   cstr_identity: constructor_identity; (* Semantic identity *)
+  cstr_layout: Variant_runtime.variant_layout option;
+      (* Runtime layout of the declaring variant; None for extension
+         constructors *)
   cstr_transparent: bool;
       (* Sole payload-carrying constructor of an unboxed type: constructing
          it is the identity at runtime *)