Reset uid counter when restoring the typer's state

src/kernel/mtyper.ml

@@ -8,6 +8,7 @@ type ('p,'t) item = {
   typedtree_items: 't list * Types.signature_item list;
   part_snapshot  : Types.snapshot;
   part_stamp     : int;
+  part_uid       : int;
   part_env       : Env.t;
   part_errors    : exn list;
   part_checks    : Typecore.delayed_check list;
@@ -26,15 +27,16 @@ let fresh_env config =
   let env0 = Extension.register Mconfig.(config.merlin.extensions) env0 in
   let snap0 = Btype.snapshot () in
   let stamp0 = Ident.get_currentstamp () in
-  (env0, snap0, stamp0)
+  let uid0 = Shape.Uid.get_current_stamp () in
+  (env0, snap0, stamp0, uid0)
 
 let get_cache config =
   match !cache with
-  | Some (env0, snap0, stamp0, items) when Types.is_valid snap0 ->
-    env0, snap0, stamp0, Some items
+  | Some (env0, snap0, stamp0, uid0, items) when Types.is_valid snap0 ->
+    env0, snap0, stamp0, uid0, Some items
   | Some _ | None ->
-    let env0, snap0, stamp0 = fresh_env config in
-    env0, snap0, stamp0, None
+    let env0, snap0, stamp0, uid0 = fresh_env config in
+    env0, snap0, stamp0, uid0, None
 
 let return_and_cache status =
   cache := Some status;
@@ -45,6 +47,7 @@ type result = {
   initial_env : Env.t;
   initial_snapshot : Types.snapshot;
   initial_stamp : int;
+  initial_uid : int;
   typedtree : [
     | `Interface of
         (Parsetree.signature_item, Typedtree.signature_item) item list
@@ -79,6 +82,7 @@ let rec type_structure caught env = function
       parsetree_item; typedtree_items; part_env;
       part_snapshot = Btype.snapshot ();
       part_stamp    = Ident.get_currentstamp ();
+      part_uid      = Shape.Uid.get_current_stamp ();
       part_errors   = !caught;
       part_checks   = !Typecore.delayed_checks;
       part_warnings = Warnings.backup ();
@@ -94,6 +98,7 @@ let rec type_signature caught env = function
       parsetree_item; typedtree_items = (sig_items, sig_type); part_env;
       part_snapshot = Btype.snapshot ();
       part_stamp    = Ident.get_currentstamp ();
+      part_uid      = Shape.Uid.get_current_stamp ();
       part_errors   = !caught;
       part_checks   = !Typecore.delayed_checks;
       part_warnings = Warnings.backup ();
@@ -102,46 +107,48 @@ let rec type_signature caught env = function
   | [] -> []
 
 let type_implementation config caught parsetree =
-  let env0, snap0, stamp0, prefix = get_cache config in
+  let env0, snap0, stamp0, uid0, prefix = get_cache config in
   let prefix, parsetree =
     match prefix with
     | Some (`Implementation items) -> compatible_prefix items parsetree
     | Some (`Interface _) | None -> ([], parsetree)
   in
-  let env', snap', stamp', warn' = match prefix with
-    | [] -> (env0, snap0, stamp0, Warnings.backup ())
+  let env', snap', stamp', uid', warn' = match prefix with
+    | [] -> (env0, snap0, stamp0, uid0, Warnings.backup ())
     | x :: _ ->
       caught := x.part_errors;
       Typecore.delayed_checks := x.part_checks;
-      (x.part_env, x.part_snapshot, x.part_stamp, x.part_warnings)
+      (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings)
   in
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
+  Shape.Uid.restore_stamp uid';
   let suffix = type_structure caught env' parsetree in
   return_and_cache
-    (env0, snap0, stamp0, `Implementation (List.rev_append prefix suffix))
+    (env0, snap0, stamp0, uid0, `Implementation (List.rev_append prefix suffix))
 
 let type_interface config caught parsetree =
-  let env0, snap0, stamp0, prefix = get_cache config in
+  let env0, snap0, stamp0, uid0, prefix = get_cache config in
   let prefix, parsetree =
     match prefix with
     | Some (`Interface items) -> compatible_prefix items parsetree
     | Some (`Implementation _) | None -> ([], parsetree)
   in
-  let env', snap', stamp', warn' = match prefix with
-    | [] -> (env0, snap0, stamp0, Warnings.backup ())
+  let env', snap', stamp', uid', warn' = match prefix with
+    | [] -> (env0, snap0, stamp0, uid0, Warnings.backup ())
     | x :: _ ->
       caught := x.part_errors;
       Typecore.delayed_checks := x.part_checks;
-      (x.part_env, x.part_snapshot, x.part_stamp, x.part_warnings)
+      (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings)
   in
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
+  Shape.Uid.restore_stamp uid';
   let suffix = type_signature caught env' parsetree in
   return_and_cache
-    (env0, snap0, stamp0, `Interface (List.rev_append prefix suffix))
+    (env0, snap0, stamp0, uid0, `Interface (List.rev_append prefix suffix))
 
 let run config parsetree =
   if not (Env.check_state_consistency ()) then (
@@ -156,12 +163,18 @@ let run config parsetree =
   let caught = ref [] in
   Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () ->
   Typecore.reset_delayed_checks ();
-  let initial_env, initial_snapshot, initial_stamp, typedtree = match parsetree with
+  let initial_env, initial_snapshot, initial_stamp, initial_uid, typedtree =
+    match parsetree with
     | `Implementation parsetree -> type_implementation config caught parsetree
     | `Interface parsetree -> type_interface config caught parsetree
   in
   Typecore.reset_delayed_checks ();
-  { config; initial_env; initial_snapshot; initial_stamp; typedtree }
+  { config;
+    initial_env;
+    initial_snapshot;
+    initial_uid;
+    initial_stamp;
+    typedtree }
 
 let get_env ?pos:_ t =
   Option.value ~default:t.initial_env (

src/ocaml/typing/shape.ml

@@ -38,10 +38,13 @@ module Uid = struct
       print fmt t
   end)
 
-  let id = ref (-1)
+  let id = Local_store.s_ref (-1)
 
   let reinit () = id := (-1)
 
+  let get_current_stamp () = !id
+  let restore_stamp i = id := i
+
   let mk  ~current_unit =
       incr id;
       Item { comp_unit = current_unit; id = !id }

src/ocaml/typing/shape.mli

@@ -57,6 +57,8 @@ module Uid : sig
     | Predef of string
 
   val reinit : unit -> unit
+  val get_current_stamp : unit -> int
+  val restore_stamp : int -> unit
 
   val mk : current_unit:string -> t
   val of_compilation_unit_id : Ident.t -> t

tests/test-dirs/server-tests/stable-uids.t

@@ -24,14 +24,5 @@ FIXME: The uids should be the same on both queries !
   $ cat log_1 | grep Found | cat >log_1g
   $ cat log_2 | grep Found | cat >log_2g
   $ diff log_1g log_2g
-  1,3c1,3
-  < Found x (File "main.ml", line 3, characters 10-11) wiht uid Main.3
-  < Found f (File "main.ml", line 4, characters 8-9) wiht uid Main.2
-  < Found x (File "main.ml", line 4, characters 10-11) wiht uid Main.1
-  ---
-  > Found x (File "main.ml", line 3, characters 10-11) wiht uid Main.7
-  > Found f (File "main.ml", line 4, characters 8-9) wiht uid Main.6
-  > Found x (File "main.ml", line 4, characters 10-11) wiht uid Main.5
-  [1]
 
   $ $MERLIN server stop-server