trivial changes

Author: riaqn

ocaml/.depend

@@ -991,6 +991,7 @@ typing/includecore.cmi : \
     typing/types.cmi \
     typing/typedtree.cmi \
     typing/path.cmi \
+    typing/mode.cmi \
     parsing/location.cmi \
     typing/jkind.cmi \
     typing/ident.cmi \

ocaml/ocamldoc/odoc_sig.ml

@@ -492,7 +492,7 @@ module Analyser =
       let record comments
           { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
         get_field env comments @@
-        {Types.ld_id; ld_mutable; ld_global = Unrestricted;
+        {Types.ld_id; ld_mutable; ld_modalities = Mode.Modality.Vector.id;
          ld_jkind=Jkind.any ~why:Dummy_jkind (* ignored *);
          ld_type=ld_type.Typedtree.ctyp_type;
          ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in

ocaml/typing/ctype.ml

@@ -3123,7 +3123,7 @@ and mcomp_record_description type_pairs env =
         mcomp type_pairs env l1.ld_type l2.ld_type;
         if Ident.name l1.ld_id = Ident.name l2.ld_id &&
            l1.ld_mutable = l2.ld_mutable &&
-           l1.ld_global = l2.ld_global
+           l1.ld_modalities = l2.ld_modalities
         then iter xs ys
         else raise Incompatible
     | [], [] -> ()

ocaml/typing/ctype.mli

@@ -186,7 +186,7 @@ type existential_treatment =
 
 val instance_constructor: existential_treatment ->
         constructor_description ->
-        (type_expr * Global_flag.t) list * type_expr * type_expr list
+        (type_expr * Modality.Vector.t) list * type_expr * type_expr list
         (* Same, for a constructor. Also returns existentials. *)
 val instance_parameterized_type:
         ?keep_names:bool ->

ocaml/typing/datarepr.ml

@@ -95,7 +95,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep =
         }
       in
       existentials,
-      [ newgenconstr path type_params, Global_flag.Unrestricted ],
+      [ newgenconstr path type_params, Modality.Vector.id ],
       Some tdecl
 
 let constructor_descrs ~current_unit ty_path decl cstrs rep =
@@ -199,7 +199,7 @@ let none =
 
 let dummy_label =
   { lbl_name = ""; lbl_res = none; lbl_arg = none;
-    lbl_mut = Immutable; lbl_global = Unrestricted;
+    lbl_mut = Immutable; lbl_modalities = Modality.Vector.id;
     lbl_jkind = Jkind.any ~why:Dummy_jkind;
     lbl_num = -1; lbl_pos = -1; lbl_all = [||];
     lbl_repres = Record_unboxed;
@@ -220,7 +220,7 @@ let label_descrs ty_res lbls repres priv =
             lbl_res = ty_res;
             lbl_arg = l.ld_type;
             lbl_mut = l.ld_mutable;
-            lbl_global = l.ld_global;
+            lbl_modalities = l.ld_modalities;
             lbl_jkind = l.ld_jkind;
             lbl_pos = if is_void then lbl_pos_void else pos;
             lbl_num = num;

ocaml/typing/outcometree.mli

@@ -71,9 +71,7 @@ type out_mutable_or_global =
   | Ogom_global
   | Ogom_immutable
 
-type out_global =
-  | Ogf_global
-  | Ogf_unrestricted
+type out_modality = Ogf_global
 
 (* should be empty if all the jkind annotations are missing *)
 type out_vars_jkinds = (string * out_jkind option) list
@@ -102,7 +100,7 @@ type out_type =
 
 and out_constructor = {
   ocstr_name: string;
-  ocstr_args: (out_type * out_global) list;
+  ocstr_args: (out_type * out_modality list) list;
   ocstr_return_type: (out_vars_jkinds * out_type) option;
 }
 
@@ -176,7 +174,7 @@ and out_extension_constructor =
   { oext_name: string;
     oext_type_name: string;
     oext_type_params: string list;
-    oext_args: (out_type * out_global) list;
+    oext_args: (out_type * out_modality list) list;
     oext_ret_type: (out_vars_jkinds * out_type) option;
     oext_private: Asttypes.private_flag }
 and out_type_extension =

ocaml/typing/predef.ml

@@ -265,7 +265,7 @@ let build_initial_env add_type add_extension empty_env =
     add_extension id
       { ext_type_path = path_exn;
         ext_type_params = [];
-        ext_args = Cstr_tuple (List.map (fun x -> (x, Global_flag.Unrestricted)) args);
+        ext_args = Cstr_tuple (List.map (fun x -> (x, Modality.Vector.id)) args);
         ext_arg_jkinds = jkinds;
         ext_constant = args = [];
         ext_ret_type = None;
@@ -310,8 +310,8 @@ let build_initial_env add_type add_extension empty_env =
        ~separability:Separability.Ind
        ~kind:(fun tvar ->
          variant [cstr ident_nil [];
-                  cstr ident_cons [tvar, Unrestricted;
-                                   type_list tvar, Unrestricted]]
+                  cstr ident_cons [tvar, Modality.Vector.id;
+                                   type_list tvar, Modality.Vector.id]]
            [| [| |]; [| list_argument_jkind;
                         Jkind.value ~why:Boxed_variant |] |] )
        ~jkind:(Jkind.value ~why:Boxed_variant)
@@ -320,7 +320,7 @@ let build_initial_env add_type add_extension empty_env =
        ~variance:Variance.covariant
        ~separability:Separability.Ind
        ~kind:(fun tvar ->
-         variant [cstr ident_none []; cstr ident_some [tvar, Unrestricted]]
+         variant [cstr ident_none []; cstr ident_some [tvar, Modality.Vector.id]]
            [| [| |]; [| option_argument_jkind |] |])
        ~jkind:(Jkind.value ~why:Boxed_variant)
   |> add_type ident_string

ocaml/typing/subst.ml

@@ -400,7 +400,7 @@ let label_declaration copy_scope s l =
   {
     ld_id = l.ld_id;
     ld_mutable = l.ld_mutable;
-    ld_global = l.ld_global;
+    ld_modalities = l.ld_modalities;
     ld_jkind = apply_prepare_jkind s l.ld_jkind l.ld_loc;
     ld_type = typexp copy_scope s l.ld_loc l.ld_type;
     ld_loc = loc s l.ld_loc;

ocaml/typing/typecore.ml

@@ -418,12 +418,6 @@ let meet_global mode =
 let meet_unique mode =
   Value.meet [mode; (Value.max_with_uniqueness Uniqueness.unique)]
 
-let meet_many mode =
-  Value.meet [mode; (Value.max_with_linearity Linearity.many)]
-
-let join_shared mode =
-  Value.join [mode; Value.min_with_uniqueness Uniqueness.shared]
-
 let value_regional_to_local mode =
   mode
   |> value_to_alloc_r2l
@@ -434,29 +428,6 @@ let value_regional_to_global mode =
   |> value_to_alloc_r2g
   |> alloc_as_value
 
-(* Describes how a modality affects field projection. Returns the mode
-   of the projection given the mode of the record. *)
-let modality_unbox_left global_flag mode =
-  let mode = Value.disallow_right mode in
-  match global_flag with
-  | Global_flag.Global ->
-      mode
-      |> Value.meet_with_regionality Regionality.Const.Global
-      |> join_shared
-      |> Value.meet_with_linearity Linearity.Const.Many
-  | Global_flag.Unrestricted -> mode
-
-(* Describes how a modality affects record construction. Gives the
-   expected mode of the field given the expected mode of the record. *)
-let modality_box_right global_flag mode =
-  match global_flag with
-  | Global_flag.Global ->
-      mode
-      |> meet_global
-      |> Value.join_with_uniqueness Uniqueness.Const.max
-      |> meet_many
-  | Global_flag.Unrestricted -> mode
-
 let mode_default mode =
   { position = RNontail;
     closure_context = None;
@@ -495,8 +466,8 @@ let mode_subcomponent expected_mode =
   let mode = alloc_as_value (value_to_alloc_r2g expected_mode.mode) in
   mode_default mode
 
-let mode_box_modality gf expected_mode =
-  mode_default (modality_box_right gf expected_mode.mode)
+let mode_box_modalities gf expected_mode =
+  mode_default (Modality.Vector.apply_right gf expected_mode.mode)
 
 let mode_global expected_mode =
   let mode = meet_global expected_mode.mode in
@@ -2672,7 +2643,7 @@ and type_pat_aux
       let args =
         List.map2
           (fun p (ty, gf) ->
-             let alloc_mode = modality_unbox_left gf alloc_mode.mode in
+             let alloc_mode = Modality.Vector.apply_left gf alloc_mode.mode in
              let alloc_mode = simple_pat_mode alloc_mode in
              type_pat ~alloc_mode tps Value p ty)
           sargs (List.combine ty_args_ty ty_args_gf)
@@ -2716,7 +2687,7 @@ and type_pat_aux
         let ty_arg =
           solve_Ppat_record_field ~refine loc env label label_lid record_ty in
         let alloc_mode =
-          modality_unbox_left label.lbl_global alloc_mode.mode
+          Modality.Vector.apply_left label.lbl_modalities alloc_mode.mode
         in
         let alloc_mode = simple_pat_mode alloc_mode in
         (label_lid, label, type_pat tps Value ~alloc_mode sarg ty_arg)
@@ -5623,14 +5594,14 @@ and type_expect_
                   unify_exp_types loc env ty_arg1 ty_arg2;
                   with_explanation (fun () ->
                     unify_exp_types loc env (instance ty_expected) ty_res2);
-                  let mode = modality_unbox_left lbl.lbl_global mode in
+                  let mode = Modality.Vector.apply_left lbl.lbl_modalities mode in
                   let rmode =
                     (* We skip a potential [mode_subcomponent] since
                        it does not affect uniqueness. *)
                     expected_mode
                   in
                   let expected_mode =
-                    mode_box_modality lbl.lbl_global rmode
+                    mode_box_modalities lbl.lbl_modalities rmode
                   in
                   Kept (ty_arg1, lbl.lbl_mut,
                         unique_use ~loc ~env mode expected_mode.mode)
@@ -5671,7 +5642,7 @@ and type_expect_
         | Record_float -> Some (register_allocation expected_mode)
         | _ -> None
       in
-      let mode = modality_unbox_left label.lbl_global rmode in
+      let mode = Modality.Vector.apply_left label.lbl_modalities rmode in
       let ty_arg =
         with_local_level_if_principal begin fun () ->
           (* ty_arg is the type of field *)
@@ -5693,7 +5664,7 @@ and type_expect_
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
-      let (record, rmode, label, expected_type) =
+      let (record, (rmode : Value.lr), label, expected_type) =
         type_label_access env srecord Env.Mutation lid in
       let ty_record =
         if expected_type = None
@@ -7158,7 +7129,7 @@ and type_label_exp create env (expected_mode : expected_mode) loc ty_expected
       expected_mode
     | _ -> mode_subcomponent expected_mode
   in
-  let arg_mode = mode_box_modality label.lbl_global rmode in
+  let arg_mode = mode_box_modalities label.lbl_modalities rmode in
   (* #4682: we try two type-checking approaches for [arg] using backtracking:
      - first try: we try with [ty_arg] as expected type;
      - second try; if that fails, we backtrack and try without
@@ -7741,7 +7712,7 @@ and type_construct env (expected_mode : expected_mode) loc lid sarg
   let args =
     List.map2
       (fun e ((ty, gf),t0) ->
-         let argument_mode = mode_box_modality gf argument_mode in
+         let argument_mode = mode_box_modalities gf argument_mode in
          type_argument ~recarg env argument_mode e ty t0)
       sargs (List.combine ty_args ty_args0)
   in

ocaml/typing/typedtree.ml

@@ -663,7 +663,7 @@ and label_declaration =
      ld_id: Ident.t;
      ld_name: string loc;
      ld_mutable: mutable_flag;
-     ld_global: Global_flag.t;
+     ld_modalities: Modality.Vector.t;
      ld_type: core_type;
      ld_loc: Location.t;
      ld_attributes: attribute list;
@@ -681,7 +681,7 @@ and constructor_declaration =
     }
 
 and constructor_arguments =
-  | Cstr_tuple of (core_type * Global_flag.t) list
+  | Cstr_tuple of (core_type * Modality.Vector.t) list
   | Cstr_record of label_declaration list
 
 and type_extension =

ocaml/typing/typedtree.mli

@@ -893,7 +893,7 @@ and label_declaration =
      ld_id: Ident.t;
      ld_name: string loc;
      ld_mutable: mutable_flag;
-     ld_global: Mode.Global_flag.t;
+     ld_modalities: Mode.Modality.Vector.t;
      ld_type: core_type;
      ld_loc: Location.t;
      ld_attributes: attributes;
@@ -911,7 +911,7 @@ and constructor_declaration =
     }
 
 and constructor_arguments =
-  | Cstr_tuple of (core_type * Mode.Global_flag.t) list
+  | Cstr_tuple of (core_type * Mode.Modality.Vector.t) list
   | Cstr_record of label_declaration list
 
 and type_extension =

ocaml/typing/types.ml

@@ -277,7 +277,7 @@ and label_declaration =
   {
     ld_id: Ident.t;
     ld_mutable: mutable_flag;
-    ld_global: Mode.Global_flag.t;
+    ld_modalities: Mode.Modality.Vector.t;
     ld_type: type_expr;
     ld_jkind : Jkind.t;
     ld_loc: Location.t;
@@ -296,7 +296,7 @@ and constructor_declaration =
   }
 
 and constructor_arguments =
-  | Cstr_tuple of (type_expr * Mode.Global_flag.t) list
+  | Cstr_tuple of (type_expr * Mode.Modality.Vector.t) list
   | Cstr_record of label_declaration list
 
 type extension_constructor =
@@ -516,7 +516,7 @@ type constructor_description =
   { cstr_name: string;                  (* Constructor name *)
     cstr_res: type_expr;                (* Type of the result *)
     cstr_existentials: type_expr list;  (* list of existentials *)
-    cstr_args: (type_expr * Mode.Global_flag.t) list;          (* Type of the arguments *)
+    cstr_args: (type_expr * Mode.Modality.Vector.t) list;          (* Type of the arguments *)
     cstr_arg_jkinds: Jkind.t array;     (* Jkinds of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
     cstr_tag: tag;                      (* Tag for heap blocks *)
@@ -602,7 +602,7 @@ type label_description =
     lbl_res: type_expr;                 (* Type of the result *)
     lbl_arg: type_expr;                 (* Type of the argument *)
     lbl_mut: mutable_flag;              (* Is this a mutable field? *)
-    lbl_global: Mode.Global_flag.t;        (* Is this a global field? *)
+    lbl_modalities: Mode.Modality.Vector.t;(* Is this a global field? *)
     lbl_jkind : Jkind.t;                (* Jkind of the argument *)
     lbl_pos: int;                       (* Position in block *)
     lbl_num: int;                       (* Position in type *)

ocaml/typing/types.mli

@@ -560,7 +560,7 @@ and label_declaration =
   {
     ld_id: Ident.t;
     ld_mutable: mutable_flag;
-    ld_global: Mode.Global_flag.t;
+    ld_modalities: Mode.Modality.Vector.t;
     ld_type: type_expr;
     ld_jkind : Jkind.t;
     ld_loc: Location.t;
@@ -579,7 +579,7 @@ and constructor_declaration =
   }
 
 and constructor_arguments =
-  | Cstr_tuple of (type_expr * Mode.Global_flag.t) list
+  | Cstr_tuple of (type_expr * Mode.Modality.Vector.t) list
   | Cstr_record of label_declaration list
 
 val tys_of_constr_args : constructor_arguments -> type_expr list
@@ -753,7 +753,7 @@ type constructor_description =
   { cstr_name: string;                  (* Constructor name *)
     cstr_res: type_expr;                (* Type of the result *)
     cstr_existentials: type_expr list;  (* list of existentials *)
-    cstr_args: (type_expr * Mode.Global_flag.t) list;          (* Type of the arguments *)
+    cstr_args: (type_expr * Mode.Modality.Vector.t) list;          (* Type of the arguments *)
     cstr_arg_jkinds: Jkind.t array;     (* Jkinds of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
     cstr_tag: tag;                      (* Tag for heap blocks *)
@@ -790,7 +790,7 @@ type label_description =
     lbl_res: type_expr;                 (* Type of the result *)
     lbl_arg: type_expr;                 (* Type of the argument *)
     lbl_mut: mutable_flag;              (* Is this a mutable field? *)
-    lbl_global: Mode.Global_flag.t;     (* Is this a global field? *)
+    lbl_modalities: Mode.Modality.Vector.t; (* Modalities on the field *)
     lbl_jkind : Jkind.t;                (* Jkind of the argument *)
     lbl_pos: int;                       (* Position in block *)
     lbl_num: int;                       (* Position in the type *)