Add Variant_with_null and Null variant constructors (#2870)

* `Variant_with_null`

* `Null` tagged constructors

* precise value kind

* No private re-export

---------

Co-authored-by: Diana Kalinichenko <[email protected]>

lambda/matching.ml

@@ -1965,6 +1965,8 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
           cstr.cstr_args
         @ rem
     | Variant_unboxed -> (arg, str, sort, layout) :: rem
+    | Variant_with_null ->
+      Misc.fatal_error "[Variant_with_null] not implemented yet"
     | Variant_extensible ->
         List.mapi
           (fun i { ca_sort } ->
@@ -2379,6 +2381,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
             in
             Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [ arg ], loc),
             lbl.lbl_sort, lbl_layout
+        | Record_inlined (_, _, Variant_with_null) -> assert false
       in
       let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in
       let str = add_barrier_to_let_kind ubr str in
@@ -3197,8 +3200,9 @@ let split_cases tag_lambda_list =
           ((runtime_tag, act) :: consts, nonconsts)
         | Ordinary {runtime_tag}, Variant_boxed _ ->
           (consts, (runtime_tag, act) :: nonconsts)
-        | _, Variant_extensible -> assert false
+        | _, (Variant_extensible | Variant_with_null) -> assert false
         | Extension _, _ -> assert false
+        | Null, _ -> Misc.fatal_error "[Null] constructors not implemented"
       )
   in
   let const, nonconst = split_rec tag_lambda_list in
@@ -3222,7 +3226,7 @@ let split_extension_cases tag_lambda_list =
        match cstr_constant, cstr_tag with
        | true, Extension path -> Left (path, act)
        | false, Extension path -> Right (path, act)
-       | _, Ordinary _ -> assert false)
+       | _, (Ordinary _ | Null) -> assert false)
     tag_lambda_list
 
 let transl_match_on_option value_kind arg loc ~if_some ~if_none =

lambda/translcore.ml

@@ -536,6 +536,9 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         | [x] -> x
         | _ -> assert false
       end else begin match cstr.cstr_tag, cstr.cstr_repr with
+      | Null, _ -> Misc.fatal_error "[Null] constructors not implemented yet"
+      | Ordinary _, Variant_with_null ->
+        Misc.fatal_error "[Variant_with_null] not implemented yet"
       | Ordinary {runtime_tag}, _ when cstr.cstr_constant ->
           assert (args_with_sorts = []);
           (* CR layouts v5: This could have void args, but for now we've ruled
@@ -609,7 +612,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                   Pmakemixedblock(0, Immutable, shape, alloc_mode)
             in
             Lprim (makeblock, lam :: ll, of_location ~scopes e.exp_loc)
-      | Extension _, (Variant_boxed _ | Variant_unboxed)
+      | Extension _, (Variant_boxed _ | Variant_unboxed | Variant_with_null)
       | Ordinary _, Variant_extensible -> assert false
       end
   | Texp_extension_constructor (_, path) ->
@@ -697,6 +700,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
           in
           Lprim (Pmixedfield (lbl.lbl_pos, read, shape, sem), [targ],
                   of_location ~scopes e.exp_loc)
+        | Record_inlined (_, _, Variant_with_null) -> assert false
       end
   | Texp_unboxed_field(arg, arg_sort, _id, lbl, _) ->
     begin match lbl.lbl_repres with
@@ -752,7 +756,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
              { value_prefix_len; flat_suffix }
            in
            Psetmixedfield(lbl.lbl_pos, write, shape, mode)
-        end
+          end
+        | Record_inlined (_, _, Variant_with_null) -> assert false
       in
       Lprim(access, [transl_exp ~scopes Jkind.Sort.Const.for_record arg;
                      transl_exp ~scopes lbl.lbl_sort newval],
@@ -1921,6 +1926,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
                 Psetmixedfield
                   (lbl.lbl_pos, write, shape, Assignment modify_heap)
               end
+            | Record_inlined (_, _, Variant_with_null) -> assert false
           in
           Lsequence(Lprim(upd, [Lvar copy_id;
                                 transl_exp ~scopes lbl.lbl_sort expr],
@@ -1994,6 +2000,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
                      { value_prefix_len; flat_suffix }
                    in
                    Pmixedfield (i, read, shape, sem)
+                 | Record_inlined (_, _, Variant_with_null) -> assert false
                in
                Lprim(access, [Lvar init_id],
                      of_location ~scopes loc),
@@ -2036,8 +2043,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
                blocks containing unboxed float literals.
             *)
             raise Not_constant
-        | Record_inlined (_, _, Variant_extensible)
-        | Record_inlined (Extension _, _, _) ->
+        | Record_inlined (_, _, (Variant_extensible | Variant_with_null))
+        | Record_inlined ((Extension _ | Null), _, _) ->
             raise Not_constant
       with Not_constant ->
         let loc = of_location ~scopes loc in
@@ -2081,6 +2088,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
             let shape = transl_mixed_product_shape shape in
             Lprim (Pmakemixedblock (runtime_tag, mut, shape, Option.get mode),
                    ll, loc)
+        | Record_inlined (_, _, Variant_with_null) -> assert false
+        | Record_inlined (Null, _, _) -> assert false
     in
     begin match opt_init_expr with
       None -> lam

lambda/value_rec_compiler.ml

@@ -237,7 +237,8 @@ let compute_static_size lam =
                           (Variant_boxed _ | Variant_extensible))
         | Record_mixed shape ->
             Block (Mixed_record (size, Lambda.transl_mixed_product_shape shape))
-        | Record_unboxed | Record_ufloat | Record_inlined (_, _, Variant_unboxed) ->
+        | Record_unboxed | Record_ufloat
+        | Record_inlined (_, _, (Variant_unboxed | Variant_with_null)) ->
             Misc.fatal_error "size_of_primitive"
         end
     | Pmakeblock _ ->

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1469,8 +1469,12 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
           (* CR layouts v5.9: support this *)
           Misc.fatal_error "Mixed blocks extensible variants are not supported")
       | Record_inlined (Extension _, _, _)
-      | Record_inlined (Ordinary _, _, (Variant_unboxed | Variant_extensible))
-      | Record_unboxed ->
+      | Record_inlined
+          ( Ordinary _,
+            _,
+            (Variant_unboxed | Variant_extensible | Variant_with_null) )
+      | Record_unboxed
+      | Record_inlined (Null, _, _) ->
         Misc.fatal_errorf "Cannot handle record kind for Pduprecord: %a"
           Printlambda.primitive prim
     in

testsuite/tests/typing-layouts-or-null/reexport.ml

@@ -335,3 +335,17 @@ let[@or_null_reexport] foo = 5
 [%%expect{|
 val foo : int = 5
 |}]
+
+(* [private] re-export fails. *)
+
+module Or_null = struct
+  type ('a : value) t : value_or_null = private 'a or_null [@@or_null_reexport]
+end
+
+[%%expect{|
+Line 2, characters 2-79:
+2 |   type ('a : value) t : value_or_null = private 'a or_null [@@or_null_reexport]
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Invalid reexport declaration.
+       Type t must be defined equal to the primitive type or_null.
+|}]

toplevel/genprintval.ml

@@ -448,6 +448,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                       match rep with
                       | Variant_unboxed -> true
                       | Variant_boxed _ | Variant_extensible -> false
+                      | Variant_with_null ->
+                        (* CR layouts v3.0: fix this. *)
+                        Misc.fatal_error "[Variant_with_null] not implemented\
+                          in bytecode"
                     in
                     begin
                       match cd_args with

toplevel/topdirs.ml

@@ -482,7 +482,7 @@ let is_exception_constructor env type_expr =
 
 let is_extension_constructor = function
   | Extension _ -> true
-  | Ordinary _ -> false
+  | Ordinary _ | Null -> false
 
 let () =
   (* This show_prim function will only show constructor types

typing/datarepr.ml

@@ -129,6 +129,12 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep =
       end
     | Variant_unboxed, ([] | _ :: _) ->
       Misc.fatal_error "Multiple or 0 constructors in [@@unboxed] variant"
+    | Variant_with_null, _ ->
+      (* CR layouts v3.5: this hardcodes ['a or_null]. Fix when we allow
+         users to write their own null constructors. *)
+      (* CR layouts v3.3: generalize to [any]. *)
+      [| Constructor_uniform_value, [| |]
+       ; Constructor_uniform_value, [| Jkind.Sort.Const.value |] |]
   in
   let all_void sorts = Array.for_all Jkind.Sort.Const.(equal void) sorts in
   let num_consts = ref 0 and num_nonconsts = ref 0 in
@@ -155,7 +161,11 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep =
       then const_tag, 1 + const_tag, nonconst_tag
       else nonconst_tag, const_tag, 1 + nonconst_tag
     in
-    let cstr_tag = Ordinary {src_index; runtime_tag} in
+    let cstr_tag =
+      match rep, cstr_constant with
+      | Variant_with_null, true -> Null
+      | _, _ ->  Ordinary {src_index; runtime_tag}
+    in
     let cstr_existentials, cstr_args, cstr_inlined =
       (* This is the representation of the inner record, IF there is one *)
       let record_repr = Record_inlined (cstr_tag, cstr_shape, rep) in
@@ -273,7 +283,7 @@ let find_constr ~constant tag cstrs =
       (function
         | ({cstr_tag=Ordinary {runtime_tag=tag'}; cstr_constant},_) ->
           tag' = tag && cstr_constant = constant
-        | ({cstr_tag=Extension _},_) -> false)
+        | ({cstr_tag=(Extension _ | Null)},_) -> false)
       cstrs
   with
   | Not_found -> raise Constr_not_found

typing/includecore.ml

@@ -306,6 +306,7 @@ type type_mismatch =
   | Variant_mismatch of variant_change list
   | Unboxed_representation of position * attributes
   | Extensible_representation of position
+  | With_null_representation of position
   | Jkind of Jkind.Violation.t
 
 let report_modality_sub_error first second ppf e =
@@ -634,6 +635,10 @@ let report_type_mismatch first second decl env ppf err =
       pr "Their internal representations differ:@ %s %s %s."
          (choose ord first second) decl
          "is extensible"
+  | With_null_representation ord ->
+      pr "Their internal representations differ:@ %s %s %s."
+         (choose ord first second) decl
+         "has a null constructor"
   | Jkind v ->
       Jkind.Violation.report_with_name ~name:first ppf v
 
@@ -989,7 +994,8 @@ module Variant_diffing = struct
     match err, rep1, rep2 with
     | None, Variant_unboxed, Variant_unboxed
     | None, Variant_boxed _, Variant_boxed _
-    | None, Variant_extensible, Variant_extensible -> None
+    | None, Variant_extensible, Variant_extensible
+    | None, Variant_with_null, Variant_with_null -> None
     | Some err, _, _ ->
         Some (Variant_mismatch err)
     | None, Variant_unboxed, Variant_boxed _ ->
@@ -1000,6 +1006,10 @@ module Variant_diffing = struct
       Some (Extensible_representation First)
     | None, _, Variant_extensible ->
       Some (Extensible_representation Second)
+    | None, Variant_with_null, _ ->
+      Some (With_null_representation First)
+    | None, _, Variant_with_null ->
+      Some (With_null_representation Second)
 end
 
 (* Inclusion between "private" annotations *)

typing/includecore.mli

@@ -119,6 +119,7 @@ type type_mismatch =
   | Variant_mismatch of variant_change list
   | Unboxed_representation of position * attributes
   | Extensible_representation of position
+  | With_null_representation of position
   | Jkind of Jkind.Violation.t
 
 type mmodes =

typing/oprint.ml

@@ -976,6 +976,11 @@ and print_out_type_decl kwd ppf td =
   let print_unboxed ppf =
     if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()
   in
+  let print_or_null_reexport ppf =
+    if td.otype_or_null_reexport then
+      fprintf ppf " [%@%@or_null_reexport]"
+    else ()
+  in
   let print_out_tkind ppf = function
   | Otyp_abstract -> ()
   | Otyp_record lbls ->
@@ -1001,12 +1006,13 @@ and print_out_type_decl kwd ppf td =
         print_private td.otype_private
         !out_type ty
   in
-  fprintf ppf "@[<2>@[<hv 2>%t%a%a@]%t%t@]"
+  fprintf ppf "@[<2>@[<hv 2>%t%a%a@]%t%t%t@]"
     print_name_params
     print_out_jkind_annot td.otype_jkind
     print_out_tkind ty
     print_constraints
     print_unboxed
+    print_or_null_reexport
 
 and print_simple_out_gf_type ppf (ty, gf) =
   let m_legacy, m_new = partition_modalities gf in

typing/outcometree.mli

@@ -204,6 +204,7 @@ and out_type_decl =
     otype_jkind: out_jkind option;
 
     otype_unboxed: bool;
+    otype_or_null_reexport: bool;
     otype_cstrs: (out_type * out_type) list }
 and out_extension_constructor =
   { oext_name: string;

typing/parmatch.ml

@@ -923,7 +923,7 @@ let should_extend ext env = match ext with
   | (p,_)::_ ->
       let open Patterns.Head in
       begin match p.pat_desc with
-      | Construct {cstr_tag=Ordinary _} ->
+      | Construct {cstr_tag=Ordinary _ | Null} ->
           let path = get_constructor_type_path p.pat_type p.pat_env in
           Path.same path ext
       | Construct {cstr_tag=Extension _} -> false
@@ -2129,7 +2129,7 @@ let extendable_path path =
     Path.same path Predef.path_option)
 
 let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct(_, {cstr_tag=Ordinary _}, ps, _) ->
+| Tpat_construct(_, {cstr_tag=Ordinary _ | Null}, ps, _) ->
     let path = get_constructor_type_path p.pat_type p.pat_env in
     List.fold_left
       collect_paths_from_pat

typing/predef.ml

@@ -477,6 +477,8 @@ let add_small_number_beta_extension_types add_type env =
   |> add_type ident_int16 ~jkind:Jkind.Const.Builtin.immediate
 
 let or_null_kind tvar =
+  (* CR layouts v3: use [Variant_with_null] when it's supported
+     in the backend. *)
   variant [cstr ident_null [];
            cstr ident_this [unrestricted tvar or_null_argument_sort]]
 

typing/printtyp.ml

@@ -1934,35 +1934,46 @@ let tree_of_type_decl id decl =
   in
   let (name, args) = type_defined decl in
   let constraints = tree_of_constraints params in
-  let ty, priv, unboxed =
+  let ty, priv, unboxed, or_null_reexport =
     match decl.type_kind with
     | Type_abstract _ ->
         begin match ty_manifest with
-        | None -> (Otyp_abstract, Public, false)
+        | None -> (Otyp_abstract, Public, false, false)
         | Some ty ->
-            tree_of_typexp Type ty, decl.type_private, false
+            tree_of_typexp Type ty, decl.type_private, false, false
         end
     | Type_variant (cstrs, rep) ->
         let unboxed =
           match rep with
           | Variant_unboxed -> true
-          | Variant_boxed _ | Variant_extensible -> false
+          | Variant_boxed _ | Variant_extensible | Variant_with_null -> false
+        in
+        (* CR layouts v3.5: remove when [Variant_with_null] is merged into
+           [Variant_unboxed]. *)
+        let or_null_reexport =
+          match rep with
+          | Variant_with_null -> true
+          | Variant_boxed _ | Variant_unboxed | Variant_extensible -> false
         in
         tree_of_manifest (Otyp_sum (List.map tree_of_constructor_in_decl cstrs)),
         decl.type_private,
-        unboxed
+        unboxed,
+        or_null_reexport
     | Type_record(lbls, rep) ->
         tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
         decl.type_private,
-        (match rep with Record_unboxed -> true | _ -> false)
+        (match rep with Record_unboxed -> true | _ -> false),
+        false
     | Type_record_unboxed_product(lbls, Record_unboxed_product) ->
         tree_of_manifest
           (Otyp_record_unboxed_product (List.map tree_of_label lbls)),
         decl.type_private,
+        false,
         false
     | Type_open ->
         tree_of_manifest Otyp_open,
         decl.type_private,
+        false,
         false
   in
   (* The algorithm for setting [lay] here is described as Case (C1) in
@@ -1984,6 +1995,7 @@ let tree_of_type_decl id decl =
       otype_private = priv;
       otype_jkind;
       otype_unboxed = unboxed;
+      otype_or_null_reexport = or_null_reexport;
       otype_cstrs = constraints }
 
 let add_type_decl_to_preparation id decl =

typing/printtyped.ml

@@ -188,6 +188,7 @@ let tag ppf = let open Types in function
   | Ordinary {src_index;runtime_tag} ->
       fprintf ppf "Ordinary {index: %d; tag: %d}" src_index runtime_tag
   | Extension p -> fprintf ppf "Extension %a" fmt_path p
+  | Null -> fprintf ppf "Null"
 
 let variant_representation i ppf = let open Types in function
   | Variant_unboxed ->
@@ -198,6 +199,7 @@ let variant_representation i ppf = let open Types in function
          sort_array (i+1) ppf sorts))
       cstrs
   | Variant_extensible -> line i ppf "Variant_inlined\n"
+  | Variant_with_null -> line i ppf "Variant_with_null\n"
 
 let flat_element i ppf flat_element =
   line i ppf "%s\n" (Types.flat_element_to_string flat_element)