diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml index 8920e76b41..0983931f1e 100644 --- a/src/kernel/mtyper.ml +++ b/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 ( diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml index 0307eb2b1b..d3f85e971c 100644 --- a/src/ocaml/typing/shape.ml +++ b/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 } diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli index 18cd20331a..45e98170f9 100644 --- a/src/ocaml/typing/shape.mli +++ b/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 diff --git a/tests/test-dirs/server-tests/stable-uids.t b/tests/test-dirs/server-tests/stable-uids.t index 0255b3d790..bd767563f6 100644 --- a/tests/test-dirs/server-tests/stable-uids.t +++ b/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