Merge branch 'main' into make-short-paths-lazier

Author: voodoos

CHANGES.md

@@ -3,7 +3,9 @@ unreleased
 
   + merlin library
     - Fix completion not working for inlined records labels (#1978, fixes #1977)
+    - Perform buffer indexing only if the query requires it (#1990 and #1991)
     - Stop unnecessarily forcing substitutions when initializing short-paths graph (#1988)
+    
 
 merlin 5.6
 ==========

src/analysis/index_occurrences.ml

@@ -25,8 +25,8 @@ let decl_of_path_or_lid env namespace path lid =
   end
   | _ -> Env_lookup.by_path path namespace env
 
-let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
-  let add uid loc = Stamped_hashtable.add index ~stamp (uid, loc) () in
+let iterator ~current_buffer_path ~index ~reduce_for_uid =
+  let add uid loc = index := Shape.Uid.Map.add_to_list uid loc !index in
   let f ~namespace env path (lid : Longident.t Location.loc) =
     log ~title:"index_buffer" "Path: %a" Logger.fmt
       (Fun.flip (Format_doc.compat Path.print) path);
@@ -92,7 +92,7 @@ let iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid =
   in
   Ast_iterators.iterator_on_usages ~f
 
-let items ~index ~stamp (config : Mconfig.t) items =
+let items index (config : Mconfig.t) items =
   let module Shape_reduce = Shape_reduce.Make (struct
     let fuel = 10
 
@@ -111,7 +111,11 @@ let items ~index ~stamp (config : Mconfig.t) items =
     Filename.concat config.query.directory config.query.filename
   in
   let reduce_for_uid = Shape_reduce.reduce_for_uid in
-  let iterator = iterator ~current_buffer_path ~index ~stamp ~reduce_for_uid in
-  match items with
-  | `Impl items -> List.iter ~f:(iterator.structure_item iterator) items
-  | `Intf items -> List.iter ~f:(iterator.signature_item iterator) items
+  let index = ref index in
+  let iterator = iterator ~current_buffer_path ~index ~reduce_for_uid in
+  let () =
+    match items with
+    | `Impl items -> List.iter ~f:(iterator.structure_item iterator) items
+    | `Intf items -> List.iter ~f:(iterator.signature_item iterator) items
+  in
+  !index

src/analysis/occurrences.ml

@@ -157,10 +157,11 @@ end = struct
 end
 
 let get_buffer_locs result uid =
-  Stamped_hashtable.fold
-    (fun (uid', loc) () acc ->
+  Shape.Uid.Map.fold
+    (fun uid' lids acc ->
        if Shape.Uid.equal uid uid' then
-         Lid_set.add (Index_format.Lid.of_lid loc) acc
+          List.fold_left lids ~init:acc ~f:(fun acc lid ->
+            Lid_set.add (Index_format.Lid.of_lid lid) acc)
        else acc)
     (Mtyper.get_index result) Lid_set.empty
 

src/kernel/mtyper.ml

@@ -3,21 +3,17 @@ open Local_store
 
 let { Logger.log } = Logger.for_section "Mtyper"
 
-let index_changelog = Local_store.s_table Stamped_hashtable.create_changelog ()
-
-type index_tbl =
-  (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t
+type index = Longident.t Location.loc list Shape.Uid.Map.t
 
 (* Forward ref to be filled by analysis.Occurrences *)
 let index_items :
-    (index:index_tbl ->
-    stamp:int ->
+    (index ->
     Mconfig.t ->
     [ `Impl of Typedtree.structure_item list
     | `Intf of Typedtree.signature_item list ] ->
-    unit)
+    index)
     ref =
-  ref (fun ~index:_ ~stamp:_ _config _item -> ())
+  ref (fun acc _config _item -> acc)
 let set_index_items f = index_items := f
 
 type ('p, 't) item =
@@ -29,7 +25,8 @@ type ('p, 't) item =
     part_env : Env.t;
     part_errors : exn list;
     part_checks : Typecore.delayed_check list;
-    part_warnings : Warnings.state
+    part_warnings : Warnings.state;
+    part_index : index lazy_t
   }
 
 type typedtree =
@@ -47,8 +44,7 @@ type 'a cache_result =
     snapshot : Types.snapshot;
     ident_stamp : int;
     uid_stamp : int;
-    value : 'a;
-    index : (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t
+    value : 'a
   }
 
 let cache : typedtree_items option cache_result option ref = s_ref None
@@ -66,8 +62,7 @@ let get_cache config =
   | Some ({ snapshot; _ } as c) when Types.is_valid snapshot -> c
   | Some _ | None ->
     let env, snapshot, ident_stamp, uid_stamp = fresh_env config in
-    let index = Stamped_hashtable.create !index_changelog 256 in
-    { env; snapshot; ident_stamp; uid_stamp; value = None; index }
+    { env; snapshot; ident_stamp; uid_stamp; value = None }
 
 let return_and_cache status =
   cache := Some { status with value = Some status.value };
@@ -81,7 +76,6 @@ type result =
     stamp : int;
     initial_uid_stamp : int;
     typedtree : typedtree_items;
-    index : (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t;
     cache_stat : typer_cache_stats
   }
 
@@ -105,11 +99,14 @@ let compatible_prefix result_items tree_items =
   in
   aux [] (result_items, tree_items)
 
-let rec type_structure caught env = function
+let rec type_structure config caught env index = function
   | parsetree_item :: rest ->
     let items, _, part_env =
       Typemod.merlin_type_structure env [ parsetree_item ]
     in
+    let part_index =
+      lazy (!index_items (Lazy.force index) config (`Impl items.str_items))
+    in
     let typedtree_items =
       (items.Typedtree.str_items, items.Typedtree.str_type)
     in
@@ -122,17 +119,21 @@ let rec type_structure caught env = function
         part_uid = Shape.Uid.get_current_stamp ();
         part_errors = !caught;
         part_checks = !Typecore.delayed_checks;
-        part_warnings = Warnings.backup ()
+        part_warnings = Warnings.backup ();
+        part_index
       }
     in
-    item :: type_structure caught part_env rest
+    item :: type_structure config caught part_env part_index rest
   | [] -> []
 
-let rec type_signature caught env = function
+let rec type_signature config caught env index = function
   | parsetree_item :: rest ->
     let { Typedtree.sig_final_env = part_env; sig_items; sig_type } =
       Typemod.merlin_transl_signature env [ parsetree_item ]
     in
+    let part_index =
+      lazy (!index_items (Lazy.force index) config (`Intf sig_items))
+    in
     let item =
       { parsetree_item;
         typedtree_items = (sig_items, sig_type);
@@ -142,82 +143,87 @@ let rec type_signature caught env = function
         part_uid = Shape.Uid.get_current_stamp ();
         part_errors = !caught;
         part_checks = !Typecore.delayed_checks;
-        part_warnings = Warnings.backup ()
+        part_warnings = Warnings.backup ();
+        part_index
       }
     in
-    item :: type_signature caught part_env rest
+    item :: type_signature config caught part_env part_index rest
   | [] -> []
 
 let type_implementation config caught parsetree =
-  let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } =
+  let { env; snapshot; ident_stamp; uid_stamp; value = prefix; _ } =
     get_cache config
   in
   let prefix, parsetree, cache_stats =
     match prefix with
     | Some (`Implementation items) -> compatible_prefix items parsetree
     | Some (`Interface _) | None -> ([], parsetree, Miss)
   in
-  let env', snap', stamp', uid_stamp', warn' =
+  let env', snap', stamp', uid_stamp', warn', index' =
     match prefix with
-    | [] -> (env, snapshot, ident_stamp, uid_stamp, Warnings.backup ())
+    | [] ->
+      ( env,
+        snapshot,
+        ident_stamp,
+        uid_stamp,
+        Warnings.backup (),
+        lazy Shape.Uid.Map.empty )
     | x :: _ ->
       caught := x.part_errors;
       Typecore.delayed_checks := x.part_checks;
-      (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings)
+      ( x.part_env,
+        x.part_snapshot,
+        x.part_stamp,
+        x.part_uid,
+        x.part_warnings,
+        x.part_index )
   in
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
-  let stamp = List.length prefix - 1 in
-  Stamped_hashtable.backtrack !index_changelog ~stamp;
   Env.cleanup_usage_tables ~stamp:uid_stamp';
   Shape.Uid.restore_stamp uid_stamp';
-  let suffix = type_structure caught env' parsetree in
-  let () =
-    List.iteri
-      ~f:(fun i { typedtree_items = items, _; _ } ->
-        let stamp = stamp + i + 1 in
-        !index_items ~index ~stamp config (`Impl items))
-      suffix
-  in
+  let suffix = type_structure config caught env' index' parsetree in
   let value = `Implementation (List.rev_append prefix suffix) in
-  ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index },
+  ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value },
     cache_stats )
 
 let type_interface config caught parsetree =
-  let { env; snapshot; ident_stamp; uid_stamp; value = prefix; index; _ } =
+  let { env; snapshot; ident_stamp; uid_stamp; value = prefix; _ } =
     get_cache config
   in
   let prefix, parsetree, cache_stats =
     match prefix with
     | Some (`Interface items) -> compatible_prefix items parsetree
     | Some (`Implementation _) | None -> ([], parsetree, Miss)
   in
-  let env', snap', stamp', uid_stamp', warn' =
+  let env', snap', stamp', uid_stamp', warn', index' =
     match prefix with
-    | [] -> (env, snapshot, ident_stamp, uid_stamp, Warnings.backup ())
+    | [] ->
+      ( env,
+        snapshot,
+        ident_stamp,
+        uid_stamp,
+        Warnings.backup (),
+        lazy Shape.Uid.Map.empty )
     | x :: _ ->
       caught := x.part_errors;
       Typecore.delayed_checks := x.part_checks;
-      (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings)
+      ( x.part_env,
+        x.part_snapshot,
+        x.part_stamp,
+        x.part_uid,
+        x.part_warnings,
+        x.part_index )
   in
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
-  let stamp = List.length prefix in
-  Stamped_hashtable.backtrack !index_changelog ~stamp;
   Env.cleanup_usage_tables ~stamp:uid_stamp';
   Shape.Uid.restore_stamp uid_stamp';
-  let suffix = type_signature caught env' parsetree in
-  let () =
-    List.iteri
-      ~f:(fun i { typedtree_items = items, _; _ } ->
-        let stamp = stamp + i + 1 in
-        !index_items ~index ~stamp config (`Intf items))
-      suffix
-  in
+  let suffix = type_signature config caught env' index' parsetree in
   let value = `Interface (List.rev_append prefix suffix) in
-  ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value; index },
+  ( return_and_cache { env; snapshot; ident_stamp; uid_stamp; value },
     cache_stats )
 
 let run config parsetree =
@@ -246,7 +252,6 @@ let run config parsetree =
     stamp;
     initial_uid_stamp = cached_result.uid_stamp;
     typedtree = cached_result.value;
-    index = cached_result.index;
     cache_stat
   }
 
@@ -285,7 +290,15 @@ let get_typedtree t =
     let sig_items, sig_type = split_items l in
     `Interface { Typedtree.sig_items; sig_type; sig_final_env = get_env t }
 
-let get_index t = t.index
+let get_index t =
+  let of_items items =
+    List.last items
+    |> Option.value_map ~default:Shape.Uid.Map.empty
+         ~f:(fun { part_index; _ } -> Lazy.force part_index)
+  in
+  match t.typedtree with
+  | `Implementation items -> of_items items
+  | `Interface items -> of_items items
 
 let get_stamp t = t.stamp
 

src/kernel/mtyper.mli

@@ -14,16 +14,14 @@ type typedtree =
 
 type typer_cache_stats = Miss | Hit of { reused : int; typed : int }
 
-type index_tbl =
-  (Shape.Uid.t * Longident.t Location.loc, unit) Stamped_hashtable.t
+type index = Longident.t Location.loc list Shape.Uid.Map.t
 
 val set_index_items :
-  (index:index_tbl ->
-  stamp:int ->
+  (index ->
   Mconfig.t ->
   [ `Impl of Typedtree.structure_item list
   | `Intf of Typedtree.signature_item list ] ->
-  unit) ->
+  index) ->
   unit
 
 val run : Mconfig.t -> Mreader.parsetree -> result
@@ -32,7 +30,7 @@ val get_env : ?pos:Msource.position -> result -> Env.t
 
 val get_typedtree : result -> typedtree
 
-val get_index : result -> index_tbl
+val get_index : result -> index
 
 val get_stamp : result -> int
 

src/ocaml/preprocess/dune

@@ -10,7 +10,7 @@
  (modules parser_raw)
  (enabled_if (<> %{profile} "release"))
  (mode    (promote (only parser_raw.ml parser_raw.mli)))
- (flags :standard --inspection --table --cmly))
+ (flags :standard --inspection --table --cmly --lalr))
 
 (rule
   (targets parser_recover.ml)

src/sherlodoc/dune

@@ -6,6 +6,6 @@
  (modules type_parser)
  (enabled_if (<> %{profile} "release"))
  (mode promote)
- (flags :standard --explain))
+ (flags :standard --explain --lalr))
 
 (ocamllex type_lexer)