Merge 5.2.0minus-19

src/analysis/construct.ml

@@ -521,7 +521,7 @@ module Gen = struct
                   val_loc = Location.none;
                   val_attributes = [];
                   val_zero_alloc = Zero_alloc.default;
-                  val_modalities = Mode.Modality.Value.id;
+                  val_modalities = Mode.Modality.id;
                   val_uid = Uid.mk ~current_unit:(Env.get_unit_name ())
                 }
               in

src/analysis/index_occurrences.ml

@@ -91,9 +91,9 @@ let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
 
 let items ~index ~stamp (config : Mconfig.t) items =
   let module Shape_reduce = Shape_reduce.Make (struct
-    let fuel = 10
+    let fuel () = Misc_stdlib.Maybe_bounded.of_int 10
 
-    let read_unit_shape ~unit_name =
+    let read_unit_shape ~diagnostics:_ ~unit_name =
       log ~title:"read_unit_shape" "inspecting %s" unit_name;
       let read unit_name =
         let cms = Format.sprintf "%s.cms" unit_name in
@@ -112,6 +112,12 @@ let items ~index ~stamp (config : Mconfig.t) items =
       | None ->
         log ~title:"read_unit_shape" "failed to find %s" unit_name;
         None
+
+    let projection_rules_for_merlin_enabled = true
+    let fuel_for_compilation_units () : Misc_stdlib.Maybe_bounded.t = Unbounded
+    let max_shape_reduce_steps_per_variable () : Misc_stdlib.Maybe_bounded.t =
+      Unbounded
+    let max_compilation_unit_depth () : Misc_stdlib.Maybe_bounded.t = Unbounded
   end) in
   let current_buffer_path =
     Filename.concat config.query.directory config.query.filename

src/analysis/locate.ml

@@ -880,8 +880,8 @@ let get_linked_uids ~config ~comp_unit decl_uid =
 let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
   let namespace = decl.namespace in
   let module Reduce = Shape_reduce.Make (struct
-    let fuel = 10
-    let read_unit_shape ~unit_name =
+    let fuel () = Misc_stdlib.Maybe_bounded.of_int 10
+    let read_unit_shape ~diagnostics:_ ~unit_name =
       log ~title:"read_unit_shape" "inspecting %s" unit_name;
       match
         load_cmt
@@ -895,6 +895,12 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
       | Error () ->
         log ~title:"read_unit_shape" "failed to find %s" unit_name;
         None
+
+    let projection_rules_for_merlin_enabled = true
+    let fuel_for_compilation_units () : Misc_stdlib.Maybe_bounded.t = Unbounded
+    let max_shape_reduce_steps_per_variable () : Misc_stdlib.Maybe_bounded.t =
+      Unbounded
+    let max_compilation_unit_depth () : Misc_stdlib.Maybe_bounded.t = Unbounded
   end) in
   let shape = Env.shape_of_path ~namespace env path in
   log ~title:"shape_of_path" "initial: %a" Logger.fmt

src/analysis/ptyp_of_type.ml

@@ -163,7 +163,7 @@ and value_description id
     { val_type; val_kind = _; val_loc; val_attributes; val_modalities; _ } =
   let type_ = core_type val_type in
   let snap = Btype.snapshot () in
-  let modalities = Mode.Modality.Value.zap_to_id val_modalities in
+  let modalities = Mode.Modality.zap_to_id val_modalities in
   Btype.backtrack snap;
   { Parsetree.pval_name = var_of_id id;
     pval_type = type_;

src/analysis/stack_or_heap_enclosing.ml

@@ -43,7 +43,7 @@ let from_nodes ~lsp_compat ~pos ~path =
          value binding. However, the LSP hover at this point will describe just the
          pattern, so we don't override the location in the [lsp_compat] regime. *)
       let loc = if lsp_compat then None else Some vb_loc in
-      ret ?loc (Alloc_mode alloc_mode.mode)
+      ret ?loc (Alloc_mode alloc_mode)
     | Expression { exp_desc; _ }, _ -> (
       match exp_desc with
       | Texp_function { alloc_mode; body; _ } -> (
@@ -76,8 +76,8 @@ let from_nodes ~lsp_compat ~pos ~path =
         in
         match body_loc with
         | Some loc when cursor_is_inside loc -> None
-        | _ -> ret (Alloc_mode alloc_mode.mode))
-      | Texp_array (_, _, _, alloc_mode) -> ret (Alloc_mode alloc_mode.mode)
+        | _ -> ret (Alloc_mode alloc_mode))
+      | Texp_array (_, _, _, alloc_mode) -> ret (Alloc_mode alloc_mode)
       | Texp_construct
           ({ loc; txt = _lident }, { cstr_repr; _ }, args, maybe_alloc_mode)
         -> (
@@ -89,7 +89,7 @@ let from_nodes ~lsp_compat ~pos ~path =
           if lsp_compat && cursor_is_inside loc then Some loc else None
         in
         match maybe_alloc_mode with
-        | Some alloc_mode -> ret ?loc (Alloc_mode alloc_mode.mode)
+        | Some alloc_mode -> ret ?loc (Alloc_mode alloc_mode)
         | None -> (
           match args with
           | [] -> ret_no_alloc ?loc "constructor without arguments"
@@ -102,18 +102,18 @@ let from_nodes ~lsp_compat ~pos ~path =
       | Texp_record { representation; alloc_mode = maybe_alloc_mode; _ } -> (
         match (maybe_alloc_mode, representation) with
         | _, Record_inlined _ -> None
-        | Some alloc_mode, _ -> ret_alloc alloc_mode.mode
+        | Some alloc_mode, _ -> ret_alloc alloc_mode
         | None, Record_unboxed -> ret_no_alloc "unboxed record"
         | None, (Record_boxed _ | Record_float | Record_ufloat | Record_mixed _)
           -> ret Unexpected_no_alloc)
       | Texp_field (_, _, _, _, boxed_or_unboxed, _) -> (
         match boxed_or_unboxed with
-        | Boxing (alloc_mode, _) -> ret_alloc alloc_mode.mode
+        | Boxing (alloc_mode, _) -> ret_alloc alloc_mode
         | Non_boxing _ -> None)
       | Texp_variant (_, maybe_exp_and_alloc_mode) ->
         maybe_exp_and_alloc_mode
         |> Option.map ~f:(fun (_, (alloc_mode : Typedtree.alloc_mode)) ->
-               alloc_mode.mode)
+               alloc_mode)
         |> ret_maybe_alloc "variant without argument"
       | _ -> None)
     | _ -> None

src/analysis/syntax_doc.ml

@@ -143,7 +143,7 @@ let get_mod_bound_doc mod_bound =
       | Everything
   end in
   let* parsed =
-    match Typemode.Axis_pair.of_string mod_bound with
+    match Typemode.Modifier_axis_pair.of_string mod_bound with
     | exception Not_found -> (
       match mod_bound with
       | "everything" -> Some Everything
@@ -200,24 +200,17 @@ let get_mod_bound_doc mod_bound =
      }
     : syntax_info)
 
-module Modal_axis_pair = struct
-  type t = P : 'a Mode.Value.Axis.t * 'a -> t
-
-  let of_string s =
-    match Typemode.Axis_pair.of_string s with
-    | exception Not_found -> None
-    | P (Modal axis, mode) -> Some (P (axis, mode))
-    | P (Nonmodal _, _) -> None
-end
-
 let get_mode_doc mode =
   let open Option.Infix in
-  let* (P (axis, mode)) = Modal_axis_pair.of_string mode in
+  let* (P (axis, mode)) =
+    match Typemode.Mode_axis_pair.of_string mode with
+    | exception Not_found -> None
+    | res -> Some res
+  in
   let* description =
     match (axis, mode) with
     | Comonadic Areality, Local ->
       Some "Values with this mode cannot escape the current region"
-    | Comonadic Areality, Regional -> None
     | Comonadic Areality, Global ->
       Some "Values with this mode can escape any region"
     | Monadic Contention, Contended ->
@@ -287,7 +280,11 @@ let get_mode_doc mode =
 
 let get_modality_doc modality =
   let open Option.Infix in
-  let* (P (axis, _)) = Modal_axis_pair.of_string modality in
+  let* (P (axis, _)) =
+    match Typemode.Modality_axis_pair.of_string modality with
+    | exception Not_found -> None
+    | res -> Some res
+  in
   let description =
     (* CR-someday: Detect the context that the modality is within to make this message
        more detailed. Ex: "This field is always stronger than _, even if the record has a

src/kernel/mconfig.ml

@@ -630,7 +630,9 @@ let ocaml_ignored_flags =
     "-cfg-prologue-validate";
     "-no-cfg-prologue-validate";
     "-cfg-prologue-shrink-wrap";
-    "-no-cfg-prologue-shrink-wrap"
+    "-no-cfg-prologue-shrink-wrap";
+    "-gdwarf-pedantic";
+    "-ddwarf-metrics"
   ]
 
 let ocaml_ignored_parametrized_flags =
@@ -710,7 +712,16 @@ let ocaml_ignored_parametrized_flags =
     "-shape-format";
     "-gdwarf-compression";
     "-gdwarf-fission";
-    "-cfg-prologue-shrink-wrap-threshold"
+    "-cfg-prologue-shrink-wrap-threshold";
+    "-gdwarf-config-shape-reduce-depth";
+    "-gdwarf-config-shape-eval-depth";
+    "-gdwarf-config-max-cms-files-per-unit";
+    "-gdwarf-config-max-cms-files-per-variable";
+    "-gdwarf-config-max-type-to-shape-depth";
+    "-gdwarf-config-max-shape-reduce-steps-per-variable";
+    "-gdwarf-config-max-evaluation-steps-per-variable";
+    "-gdwarf-config-shape-reduce-fuel";
+    "-gdwarf-fidelity"
   ]
 
 let ocaml_warnings_spec ~error =

src/kernel/mtyper.ml

@@ -40,7 +40,7 @@ type typedtree_items =
   | Interface_items of
       { items : (Parsetree.signature_item, Typedtree.signature_item) item list;
         psig_modalities : Parsetree.modalities;
-        sig_modalities : Mode.Modality.Value.Const.t;
+        sig_modalities : Mode.Modality.Const.t;
         sig_sloc : Location.t
       }
   | Implementation_items of

src/ocaml-index/lib/index.ml

@@ -50,7 +50,7 @@ module Reduce_conf (Loaded_shapes : sig
   val shapes : (Compilation_unit.t, Shape.t) Hashtbl.t
 end) =
 struct
-  let fuel = 10
+  let fuel () = Misc_stdlib.Maybe_bounded.of_int 10
 
   let try_load ~unit_name () =
     match
@@ -83,9 +83,15 @@ struct
       | Some artifact -> Merlin_analysis.Locate.Artifact.impl_shape artifact
     end
 
-  let read_unit_shape ~unit_name =
+  let read_unit_shape ~diagnostics:_ ~unit_name =
     Log.debug "Read unit shape: %s\n%!" unit_name;
     try_load ~unit_name ()
+
+  let projection_rules_for_merlin_enabled = true
+  let fuel_for_compilation_units () : Misc_stdlib.Maybe_bounded.t = Unbounded
+  let max_shape_reduce_steps_per_variable () : Misc_stdlib.Maybe_bounded.t =
+    Unbounded
+  let max_compilation_unit_depth () : Misc_stdlib.Maybe_bounded.t = Unbounded
 end
 
 let init_load_path_once ~do_not_use_cmt_loadpath =

src/ocaml/parsing/ast_mapper.ml

@@ -102,6 +102,7 @@ module C = struct
     | Pconst_integer _
     | Pconst_unboxed_integer _
     | Pconst_char _
+    | Pconst_untagged_char _
     | Pconst_float _
     | Pconst_unboxed_float _
       -> c

src/ocaml/parsing/asttypes.mli

@@ -73,4 +73,6 @@ type index_kind =
   | Index_int
   | Index_unboxed_int64
   | Index_unboxed_int32
+  | Index_unboxed_int16
+  | Index_unboxed_int8
   | Index_unboxed_nativeint

src/ocaml/parsing/parsetree.mli

@@ -33,9 +33,11 @@ type constant =
       (** Integer constants such as [#3] [#3l] [#3L] [#3n].
 
           A suffix [[g-z][G-Z]] is required by the parser.
-          Suffixes except ['l'], ['L'] and ['n'] are rejected by the typechecker
+          Suffixes except ['s'], ['S'], ['l'], ['L'], ['n'], and ['m'] are
+          rejected by the typechecker
       *)
   | Pconst_char of char  (** Character such as ['c']. *)
+  | Pconst_untagged_char of char  (** Untagged character such as [#'c']. *)
   | Pconst_string of string * Location.t * string option
       (** Constant string such as ["constant"] or
           [{delim|other constant|delim}].
@@ -636,10 +638,13 @@ and block_access =
   | Baccess_field of Longident.t loc
       (** [.foo] *)
   | Baccess_array of mutable_flag * index_kind * expression
-      (** Mutable array accesses: [.(E)], [.L(E)], [.l(E)], [.n(E)]
-          Immutable array accesses: [.:(E)], [.:L(E)], [.:l(E)], [.:n(E)]
+      (** Mutable array accesses:
+            [.(E)], [.L(E)], [.l(E)], [.S(E)], [.s(E)], [.n(E)]
+          Immutable array accesses:
+            [.:(E)], [.:L(E)], [.:l(E)], [.:S(E)], [.:s(E)], [.:n(E)]
 
-          Indexed by [int], [int64#], [int32#], or [nativeint#], respectively.
+          Indexed by [int], [int64#], [int32#], [int16#], [int8#], or
+          [nativeint#], respectively.
       *)
   | Baccess_block of mutable_flag * expression
       (** Access using another block index: [.idx_imm(E)], [.idx_mut(E)]
@@ -1332,7 +1337,8 @@ and jkind_annotation_desc =
   | Default
   | Abbreviation of string
   (* CR layouts v2.8: [mod] can have only layouts on the left, not
-     full kind annotations. We may want to narrow this type some. *)
+     full kind annotations. We may want to narrow this type some.
+     Internal ticket 5085. *)
   | Mod of jkind_annotation * modes
   | With of jkind_annotation * core_type * modalities
   | Kind_of of core_type

src/ocaml/parsing/pprintast.ml

@@ -246,6 +246,8 @@ let longident_loc f x = pp f "%a" longident x.txt
 let constant f = function
   | Pconst_char i ->
       pp f "%C"  i
+  | Pconst_untagged_char i ->
+      pp f "#%C"  i
   | Pconst_string (i, _, None) ->
       pp f "%S" i
   | Pconst_string (i, _, Some delim) ->
@@ -2248,6 +2250,8 @@ and block_access ctxt f = function
       | Index_int -> ""
       | Index_unboxed_int64 -> "L"
       | Index_unboxed_int32 -> "l"
+      | Index_unboxed_int16 -> "S"
+      | Index_unboxed_int8 -> "s"
       | Index_unboxed_nativeint -> "n"
     in
     pp f "%s%s(%a)" dotop suffix (expression ctxt) index

src/ocaml/parsing/printast.ml

@@ -64,6 +64,8 @@ let fmt_constant f x =
   | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m
   | Pconst_unboxed_integer (i,m) -> fprintf f "PConst_unboxed_int (%s,%c)" i m
   | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c)
+  | Pconst_untagged_char (c) ->
+      fprintf f "PConst_untagged_char %02x" (Char.code c)
   | Pconst_string (s, strloc, None) ->
       fprintf f "PConst_string(%S,%a,None)" s fmt_location strloc
   | Pconst_string (s, strloc, Some delim) ->
@@ -111,6 +113,8 @@ let fmt_index_kind f = function
   | Index_int -> fprintf f "Index_int"
   | Index_unboxed_int64 -> fprintf f "Index_unboxed_int64"
   | Index_unboxed_int32 -> fprintf f "Index_unboxed_int32"
+  | Index_unboxed_int16 -> fprintf f "Index_unboxed_int16"
+  | Index_unboxed_int8 -> fprintf f "Index_unboxed_int8"
   | Index_unboxed_nativeint -> fprintf f "Index_unboxed_nativeint"
 
 let line i f s (*...*) =