From 9fdc759ac0847de5380e25882d690bb22a89df24 Mon Sep 17 00:00:00 2001 From: Thomas Refis Date: Thu, 15 Oct 2020 14:47:19 +0200 Subject: [PATCH] Centralized tracking of frontend's global state (#9963) import Local_store from merlin, with a simplified API following review comments --- .depend | 19 ++++++ Changes | 3 + compilerlibs/Makefile.compilerlibs | 3 +- dune | 2 +- otherlibs/dynlink/Makefile | 1 + tools/Makefile | 4 +- typing/btype.ml | 20 +++--- typing/ctype.ml | 10 +-- typing/env.ml | 104 +++++++++++++++-------------- typing/ident.ml | 6 +- typing/subst.ml | 4 +- utils/config.mli | 6 ++ utils/config.mlp | 2 + utils/load_path.ml | 14 +++- utils/local_store.ml | 74 ++++++++++++++++++++ utils/local_store.mli | 66 ++++++++++++++++++ 16 files changed, 265 insertions(+), 73 deletions(-) create mode 100644 utils/local_store.ml create mode 100644 utils/local_store.mli diff --git a/.depend b/.depend index de33bcee8..487599130 100644 --- a/.depend +++ b/.depend @@ -77,11 +77,20 @@ utils/int_replace_polymorphic_compare.cmx : \ utils/int_replace_polymorphic_compare.cmi : utils/load_path.cmo : \ utils/misc.cmi \ + utils/local_store.cmi \ + utils/config.cmi \ utils/load_path.cmi utils/load_path.cmx : \ utils/misc.cmx \ + utils/local_store.cmx \ + utils/config.cmx \ utils/load_path.cmi utils/load_path.cmi : +utils/local_store.cmo : \ + utils/local_store.cmi +utils/local_store.cmx : \ + utils/local_store.cmi +utils/local_store.cmi : utils/misc.cmo : \ utils/config.cmi \ utils/build_path_prefix_map.cmi \ @@ -433,12 +442,14 @@ typing/annot.cmi : \ typing/btype.cmo : \ typing/types.cmi \ typing/path.cmi \ + utils/local_store.cmi \ typing/ident.cmi \ parsing/asttypes.cmi \ typing/btype.cmi typing/btype.cmx : \ typing/types.cmx \ typing/path.cmx \ + utils/local_store.cmx \ typing/ident.cmx \ parsing/asttypes.cmi \ typing/btype.cmi @@ -483,6 +494,7 @@ typing/ctype.cmo : \ utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + utils/local_store.cmi \ typing/ident.cmi \ typing/env.cmi \ utils/clflags.cmi \ @@ -498,6 +510,7 @@ typing/ctype.cmx : \ utils/misc.cmx \ parsing/longident.cmx \ parsing/location.cmx \ + utils/local_store.cmx \ typing/ident.cmx \ typing/env.cmx \ utils/clflags.cmx \ @@ -542,6 +555,7 @@ typing/env.cmo : \ utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + utils/local_store.cmi \ utils/load_path.cmi \ typing/ident.cmi \ typing/datarepr.cmi \ @@ -561,6 +575,7 @@ typing/env.cmx : \ utils/misc.cmx \ parsing/longident.cmx \ parsing/location.cmx \ + utils/local_store.cmx \ utils/load_path.cmx \ typing/ident.cmx \ typing/datarepr.cmx \ @@ -606,11 +621,13 @@ typing/envaux.cmi : \ typing/env.cmi typing/ident.cmo : \ utils/misc.cmi \ + utils/local_store.cmi \ utils/identifiable.cmi \ utils/clflags.cmi \ typing/ident.cmi typing/ident.cmx : \ utils/misc.cmx \ + utils/local_store.cmx \ utils/identifiable.cmx \ utils/clflags.cmx \ typing/ident.cmi @@ -1066,6 +1083,7 @@ typing/subst.cmo : \ parsing/parsetree.cmi \ utils/misc.cmi \ parsing/location.cmi \ + utils/local_store.cmi \ typing/ident.cmi \ utils/clflags.cmi \ typing/btype.cmi \ @@ -1077,6 +1095,7 @@ typing/subst.cmx : \ parsing/parsetree.cmi \ utils/misc.cmx \ parsing/location.cmx \ + utils/local_store.cmx \ typing/ident.cmx \ utils/clflags.cmx \ typing/btype.cmx \ diff --git a/Changes b/Changes index c621e5bb2..4ae790e5c 100644 --- a/Changes +++ b/Changes @@ -466,6 +466,9 @@ Working version - #9003: Start compilation from Emit when the input file is in Linear IR format. (Greta Yorsh, review by Jérémie Dimino, Gabriel Scherer and Frédéric Bour) +- #9963: Centralized tracking of frontend's global state + (Frédéric Bour and Thomas Refis, review by Gabriel Scherer) + ### Build system: - #7121, #9558: Always the autoconf-discovered ld in PACKLD. For diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index e4f469b8a..315add7e8 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -26,7 +26,8 @@ UTILS=utils/config.cmo utils/build_path_prefix_map.cmo utils/misc.cmo \ utils/identifiable.cmo utils/numbers.cmo utils/arg_helper.cmo \ - utils/clflags.cmo utils/profile.cmo utils/load_path.cmo \ + utils/clflags.cmo utils/profile.cmo utils/local_store.cmo \ + utils/load_path.cmo \ utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ utils/consistbl.cmo utils/strongly_connected_components.cmo \ utils/targetint.cmo utils/int_replace_polymorphic_compare.cmo \ diff --git a/dune b/dune index 7e277e368..aa026eb5d 100644 --- a/dune +++ b/dune @@ -45,7 +45,7 @@ ;; UTILS config build_path_prefix_map misc identifiable numbers arg_helper clflags profile terminfo ccomp warnings consistbl strongly_connected_components - targetint load_path int_replace_polymorphic_compare binutils + targetint load_path int_replace_polymorphic_compare binutils local_store ;; PARSING location longident docstrings syntaxerr ast_helper camlinternalMenhirLib diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 09d659a2e..1beacfa0b 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -82,6 +82,7 @@ COMPILERLIBS_SOURCES=\ utils/consistbl.ml \ utils/terminfo.ml \ utils/warnings.ml \ + utils/local_store.ml \ utils/load_path.ml \ utils/int_replace_polymorphic_compare.ml \ parsing/location.ml \ diff --git a/tools/Makefile b/tools/Makefile index aa54e5b27..07e2eda1a 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -113,7 +113,7 @@ $(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),) ocamlcp_cmos = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \ warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \ - clflags.cmo \ + clflags.cmo local_store.cmo \ terminfo.cmo location.cmo load_path.cmo ccomp.cmo compenv.cmo \ main_args.cmo @@ -161,7 +161,7 @@ clean:: OCAMLMKTOP=ocamlmktop.cmo OCAMLMKTOP_IMPORTS=config.cmo build_path_prefix_map.cmo misc.cmo \ identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo \ - load_path.cmo profile.cmo ccomp.cmo + local_store.cmo load_path.cmo profile.cmo ccomp.cmo $(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),) diff --git a/typing/btype.ml b/typing/btype.ml index bec31496d..98531f15d 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -18,6 +18,8 @@ open Asttypes open Types +open Local_store + (**** Sets, maps and hashtables of types ****) module TypeSet = Set.Make(TypeOps) @@ -40,7 +42,7 @@ let pivot_level = 2 * lowest_level - 1 (**** Some type creators ****) -let new_id = ref (-1) +let new_id = s_ref (-1) let newty2 level desc = incr new_id; { desc; level; scope = lowest_level; id = !new_id } @@ -82,14 +84,14 @@ type changes = | Unchanged | Invalid -let trail = Weak.create 1 +let trail = s_table Weak.create 1 let log_change ch = - match Weak.get trail 0 with None -> () + match Weak.get !trail 0 with None -> () | Some r -> let r' = ref Unchanged in r := Change (ch, r'); - Weak.set trail 0 (Some r') + Weak.set !trail 0 (Some r') (**** Representative of a type ****) @@ -633,7 +635,7 @@ let rec check_expans visited ty = | _ -> () *) -let memo = ref [] +let memo = s_ref [] (* Contains the list of saved abbreviation expansions. *) let cleanup_abbrev () = @@ -718,7 +720,7 @@ let undo_change = function | Ctypeset (r, v) -> r := v type snapshot = changes ref * int -let last_snapshot = ref 0 +let last_snapshot = s_ref 0 let log_type ty = if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) @@ -771,10 +773,10 @@ let set_typeset rs s = let snapshot () = let old = !last_snapshot in last_snapshot := !new_id; - match Weak.get trail 0 with Some r -> (r, old) + match Weak.get !trail 0 with Some r -> (r, old) | None -> let r = ref Unchanged in - Weak.set trail 0 (Some r); + Weak.set !trail 0 (Some r); (r, old) let rec rev_log accu = function @@ -795,7 +797,7 @@ let backtrack (changes, old) = List.iter undo_change backlog; changes := Unchanged; last_snapshot := old; - Weak.set trail 0 (Some changes) + Weak.set !trail 0 (Some changes) let rec rev_compress_log log r = match !r with diff --git a/typing/ctype.ml b/typing/ctype.ml index a4e41966f..135d227ff 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -20,6 +20,8 @@ open Asttypes open Types open Btype +open Local_store + (* Type manipulation after type inference ====================================== @@ -181,10 +183,10 @@ exception Cannot_apply (**** Type level management ****) -let current_level = ref 0 -let nongen_level = ref 0 -let global_level = ref 1 -let saved_level = ref [] +let current_level = s_ref 0 +let nongen_level = s_ref 0 +let global_level = s_ref 1 +let saved_level = s_ref [] type levels = { current_level: int; nongen_level: int; global_level: int; diff --git a/typing/env.ml b/typing/env.ml index ee293098c..09d341e8e 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -23,6 +23,8 @@ open Path open Types open Btype +open Local_store + module String = Misc.Stdlib.String let add_delayed_check_forward = ref (fun _ -> assert false) @@ -35,9 +37,9 @@ type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t (inclusion test between signatures, cf Includemod.value_descriptions, ...). *) -let value_declarations : unit usage_tbl = Types.Uid.Tbl.create 16 -let type_declarations : unit usage_tbl = Types.Uid.Tbl.create 16 -let module_declarations : unit usage_tbl = Types.Uid.Tbl.create 16 +let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 +let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 type constructor_usage = Positive | Pattern | Privatize type constructor_usages = @@ -64,7 +66,8 @@ let add_constructor_usage ~rebind priv cu usage = let constructor_usages () = {cu_positive = false; cu_pattern = false; cu_privatize = false} -let used_constructors : constructor_usage usage_tbl = Types.Uid.Tbl.create 16 +let used_constructors : constructor_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 (** Map indexed by the name of module components. *) module NameMap = String.Map @@ -769,57 +772,57 @@ let read_sign_of_cmi = sign_of_cmi ~freshen:true let save_sign_of_cmi = sign_of_cmi ~freshen:false -let persistent_env : module_data Persistent_env.t = - Persistent_env.empty () +let persistent_env : module_data Persistent_env.t ref = + s_table Persistent_env.empty () let without_cmis f x = - Persistent_env.without_cmis persistent_env f x + Persistent_env.without_cmis !persistent_env f x -let imports () = Persistent_env.imports persistent_env +let imports () = Persistent_env.imports !persistent_env let import_crcs ~source crcs = - Persistent_env.import_crcs persistent_env ~source crcs + Persistent_env.import_crcs !persistent_env ~source crcs let read_pers_mod modname filename = - Persistent_env.read persistent_env read_sign_of_cmi modname filename + Persistent_env.read !persistent_env read_sign_of_cmi modname filename let find_pers_mod name = - Persistent_env.find persistent_env read_sign_of_cmi name + Persistent_env.find !persistent_env read_sign_of_cmi name let check_pers_mod ~loc name = - Persistent_env.check persistent_env read_sign_of_cmi ~loc name + Persistent_env.check !persistent_env read_sign_of_cmi ~loc name let crc_of_unit name = - Persistent_env.crc_of_unit persistent_env read_sign_of_cmi name + Persistent_env.crc_of_unit !persistent_env read_sign_of_cmi name let is_imported_opaque modname = - Persistent_env.is_imported_opaque persistent_env modname + Persistent_env.is_imported_opaque !persistent_env modname let register_import_as_opaque modname = - Persistent_env.register_import_as_opaque persistent_env modname + Persistent_env.register_import_as_opaque !persistent_env modname let reset_declaration_caches () = - Types.Uid.Tbl.clear value_declarations; - Types.Uid.Tbl.clear type_declarations; - Types.Uid.Tbl.clear module_declarations; - Types.Uid.Tbl.clear used_constructors; + Types.Uid.Tbl.clear !value_declarations; + Types.Uid.Tbl.clear !type_declarations; + Types.Uid.Tbl.clear !module_declarations; + Types.Uid.Tbl.clear !used_constructors; () let reset_cache () = Current_unit_name.set ""; - Persistent_env.clear persistent_env; + Persistent_env.clear !persistent_env; reset_declaration_caches (); () let reset_cache_toplevel () = - Persistent_env.clear_missing persistent_env; + Persistent_env.clear_missing !persistent_env; reset_declaration_caches (); () (* get_components *) let get_components_res c = - match Persistent_env.can_load_cmis persistent_env with + match Persistent_env.can_load_cmis !persistent_env with | Persistent_env.Can_load_cmis -> EnvLazy.force !components_of_module_maker' c.comps | Persistent_env.Cannot_load_cmis log -> @@ -1066,7 +1069,7 @@ let find_hash_type path env = | Papply _ -> raise Not_found -let required_globals = ref [] +let required_globals = s_ref [] let reset_required_globals () = required_globals := [] let get_required_globals () = !required_globals let add_required_global id = @@ -1243,7 +1246,7 @@ let rec scrape_alias_for_visit env (sub : Subst.t option) mty = begin match may_subst Subst.module_path sub path with | Pident id when Ident.persistent id - && not (Persistent_env.looked_up persistent_env (Ident.name id)) -> + && not (Persistent_env.looked_up !persistent_env (Ident.name id)) -> false | path -> (* PR#6600: find_module may raise Not_found *) try scrape_alias_for_visit env sub (find_module path env).md_type @@ -1283,7 +1286,7 @@ let iter_env wrap proj1 proj2 f env () = iter_components (Pident id) path data.mda_components | Mod_persistent -> let modname = Ident.name id in - match Persistent_env.find_in_cache persistent_env modname with + match Persistent_env.find_in_cache !persistent_env modname with | None -> () | Some data -> iter_components (Pident id) path data.mda_components) @@ -1304,7 +1307,7 @@ let same_types env1 env2 = env1.types == env2.types && env1.modules == env2.modules let used_persistent () = - Persistent_env.fold persistent_env + Persistent_env.fold !persistent_env (fun s _m r -> Concr.add s r) Concr.empty @@ -1674,7 +1677,7 @@ and check_value_name name loc = and store_value ?check id addr decl env = check_value_name (Ident.name id) decl.val_loc; Option.iter - (fun f -> check_usage decl.val_loc id decl.val_uid f value_declarations) + (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) check; let vda = { vda_description = decl; vda_address = addr } in { env with @@ -1686,7 +1689,7 @@ and store_type ~check id info env = if check then check_usage loc id info.type_uid (fun s -> Warnings.Unused_type_declaration s) - type_declarations; + !type_declarations; let path = Pident id in let constructors = Datarepr.constructors_of_type path info @@ -1705,9 +1708,9 @@ and store_type ~check id info env = let name = cstr.cstr_name in let loc = cstr.cstr_loc in let k = cstr.cstr_uid in - if not (Types.Uid.Tbl.mem used_constructors k) then + if not (Types.Uid.Tbl.mem !used_constructors k) then let used = constructor_usages () in - Types.Uid.Tbl.add used_constructors k + Types.Uid.Tbl.add !used_constructors k (add_constructor_usage ~rebind:false priv used); if not (ty_name = "" || ty_name.[0] = '_') then !add_delayed_check_forward @@ -1757,9 +1760,9 @@ and store_extension ~check ~rebind id addr ext env = let is_exception = Path.same ext.ext_type_path Predef.path_exn in let name = cstr.cstr_name in let k = cstr.cstr_uid in - if not (Types.Uid.Tbl.mem used_constructors k) then begin + if not (Types.Uid.Tbl.mem !used_constructors k) then begin let used = constructor_usages () in - Types.Uid.Tbl.add used_constructors k + Types.Uid.Tbl.add !used_constructors k (add_constructor_usage ~rebind priv used); !add_delayed_check_forward (fun () -> @@ -1778,7 +1781,7 @@ and store_extension ~check ~rebind id addr ext env = and store_module ~check ~freshening_sub id addr presence md env = let loc = md.md_loc in Option.iter - (fun f -> check_usage loc id md.md_uid f module_declarations) check; + (fun f -> check_usage loc id md.md_uid f !module_declarations) check; let alerts = Builtin_attributes.alerts_of_attrs md.md_attributes in let module_decl_lazy = match freshening_sub with @@ -2125,11 +2128,11 @@ let save_signature_with_transform cmi_transform ~alerts sg modname filename = Subst.reset_for_saving (); let sg = Subst.signature Make_local (Subst.for_saving Subst.identity) sg in let cmi = - Persistent_env.make_cmi persistent_env modname sg alerts + Persistent_env.make_cmi !persistent_env modname sg alerts |> cmi_transform in let pm = save_sign_of_cmi { Persistent_env.Persistent_signature.cmi; filename } in - Persistent_env.save_cmi persistent_env + Persistent_env.save_cmi !persistent_env { Persistent_env.Persistent_signature.filename; cmi } pm; cmi @@ -2152,19 +2155,19 @@ let (initial_safe_string, initial_unsafe_string) = (* Tracking usage *) let mark_module_used uid = - match Types.Uid.Tbl.find module_declarations uid with + match Types.Uid.Tbl.find !module_declarations uid with | mark -> mark () | exception Not_found -> () let mark_modtype_used _uid = () let mark_value_used uid = - match Types.Uid.Tbl.find value_declarations uid with + match Types.Uid.Tbl.find !value_declarations uid with | mark -> mark () | exception Not_found -> () let mark_type_used uid = - match Types.Uid.Tbl.find type_declarations uid with + match Types.Uid.Tbl.find !type_declarations uid with | mark -> mark () | exception Not_found -> () @@ -2174,12 +2177,12 @@ let mark_type_path_used env path = | exception Not_found -> () let mark_constructor_used usage cd = - match Types.Uid.Tbl.find used_constructors cd.cd_uid with + match Types.Uid.Tbl.find !used_constructors cd.cd_uid with | mark -> mark usage | exception Not_found -> () let mark_extension_used usage ext = - match Types.Uid.Tbl.find used_constructors ext.ext_uid with + match Types.Uid.Tbl.find !used_constructors ext.ext_uid with | mark -> mark usage | exception Not_found -> () @@ -2190,7 +2193,7 @@ let mark_constructor_description_used usage env cstr = | _ -> assert false in mark_type_path_used env ty_path; - match Types.Uid.Tbl.find used_constructors cstr.cstr_uid with + match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with | mark -> mark usage | exception Not_found -> () @@ -2203,25 +2206,26 @@ let mark_label_description_used () env lbl = mark_type_path_used env ty_path let mark_class_used uid = - match Types.Uid.Tbl.find type_declarations uid with + match Types.Uid.Tbl.find !type_declarations uid with | mark -> mark () | exception Not_found -> () let mark_cltype_used uid = - match Types.Uid.Tbl.find type_declarations uid with + match Types.Uid.Tbl.find !type_declarations uid with | mark -> mark () | exception Not_found -> () let set_value_used_callback vd callback = - Types.Uid.Tbl.add value_declarations vd.val_uid callback + Types.Uid.Tbl.add !value_declarations vd.val_uid callback let set_type_used_callback td callback = if Uid.for_actual_declaration td.type_uid then let old = - try Types.Uid.Tbl.find type_declarations td.type_uid + try Types.Uid.Tbl.find !type_declarations td.type_uid with Not_found -> ignore in - Types.Uid.Tbl.replace type_declarations td.type_uid (fun () -> callback old) + Types.Uid.Tbl.replace !type_declarations td.type_uid + (fun () -> callback old) (* Lookup by name *) @@ -2866,7 +2870,7 @@ let fold_modules f lid env acc = in f name p md acc | Mod_persistent -> - match Persistent_env.find_in_cache persistent_env name with + match Persistent_env.find_in_cache !persistent_env name with | None -> acc | Some mda -> let md = @@ -2927,7 +2931,7 @@ let filter_non_loaded_persistent f env = | Mod_local _ -> acc | Mod_unbound _ -> acc | Mod_persistent -> - match Persistent_env.find_in_cache persistent_env name with + match Persistent_env.find_in_cache !persistent_env name with | Some _ -> acc | None -> if f (Ident.create_persistent name) then @@ -2992,8 +2996,8 @@ let summary env = if Path.Map.is_empty env.local_constraints then env.summary else Env_constraints (env.summary, env.local_constraints) -let last_env = ref empty -let last_reduced_env = ref empty +let last_env = s_ref empty +let last_reduced_env = s_ref empty let keep_only_summary env = if !last_env == env then !last_reduced_env diff --git a/typing/ident.ml b/typing/ident.ml index 6296398b0..feb590d02 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -13,6 +13,8 @@ (* *) (**************************************************************************) +open Local_store + let lowest_scope = 0 let highest_scope = 100000000 @@ -26,8 +28,8 @@ type t = (* A stamp of 0 denotes a persistent identifier *) -let currentstamp = ref 0 -let predefstamp = ref 0 +let currentstamp = s_ref 0 +let predefstamp = s_ref 0 let create_scoped ~scope s = incr currentstamp; diff --git a/typing/subst.ml b/typing/subst.ml index 9d209b2f7..9ad1ecb58 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -20,6 +20,8 @@ open Path open Types open Btype +open Local_store + type type_replacement = | Path of Path.t | Type_function of { params : type_expr list; body : type_expr } @@ -124,7 +126,7 @@ let to_subst_by_type_function s p = (* Special type ids for saved signatures *) -let new_id = ref (-1) +let new_id = s_ref (-1) let reset_for_saving () = new_id := -1 let newpersty desc = diff --git a/utils/config.mli b/utils/config.mli index c4464df85..1b73eed02 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -244,3 +244,9 @@ val print_config : out_channel -> unit val config_var : string -> string option (** the configuration value of a variable, if it exists *) + +(**/**) + +val merlin : bool + +(**/**) diff --git a/utils/config.mlp b/utils/config.mlp index 1dab79836..01a4561f6 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -237,3 +237,5 @@ let config_var x = | Bool b -> string_of_bool b in Some s + +let merlin = false diff --git a/utils/load_path.ml b/utils/load_path.ml index bced584db..41eb22e9e 100644 --- a/utils/load_path.ml +++ b/utils/load_path.ml @@ -12,13 +12,15 @@ (* *) (**************************************************************************) +open Local_store + module SMap = Misc.Stdlib.String.Map (* Mapping from basenames to full filenames *) type registry = string SMap.t ref -let files : registry = ref SMap.empty -let files_uncap : registry = ref SMap.empty +let files : registry = s_ref SMap.empty +let files_uncap : registry = s_ref SMap.empty module Dir = struct type t = { @@ -42,9 +44,10 @@ module Dir = struct { path; files = Array.to_list (readdir_compat path) } end -let dirs = ref [] +let dirs = s_ref [] let reset () = + assert (not Config.merlin || Local_store.is_bound ()); files := SMap.empty; files_uncap := SMap.empty; dirs := [] @@ -64,6 +67,7 @@ let add_to_maps fn basenames files files_uncap = name already exists in the cache simply by adding entries in reverse order. *) let add dir = + assert (not Config.merlin || Local_store.is_bound ()); let new_files, new_files_uncap = add_to_maps (Filename.concat dir.Dir.path) dir.Dir.files !files !files_uncap @@ -77,6 +81,7 @@ let init l = List.iter add !dirs let remove_dir dir = + assert (not Config.merlin || Local_store.is_bound ()); let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in if List.compare_lengths new_dirs !dirs <> 0 then begin reset (); @@ -88,6 +93,7 @@ let remove_dir dir = add a basename to the cache if it is not already present in the cache, in order to enforce left-to-right precedence. *) let add dir = + assert (not Config.merlin || Local_store.is_bound ()); let new_files, new_files_uncap = add_to_maps (Filename.concat dir.Dir.path) dir.Dir.files SMap.empty SMap.empty @@ -102,12 +108,14 @@ let add_dir dir = add (Dir.create dir) let is_basename fn = Filename.basename fn = fn let find fn = + assert (not Config.merlin || Local_store.is_bound ()); if is_basename fn then SMap.find fn !files else Misc.find_in_path (get_paths ()) fn let find_uncap fn = + assert (not Config.merlin || Local_store.is_bound ()); if is_basename fn then SMap.find (String.uncapitalize_ascii fn) !files_uncap else diff --git a/utils/local_store.ml b/utils/local_store.ml new file mode 100644 index 000000000..4babf61d8 --- /dev/null +++ b/utils/local_store.ml @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Frederic Bour, Tarides *) +(* Thomas Refis, Tarides *) +(* *) +(* Copyright 2020 Tarides *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ref_and_reset = + | Table : { ref: 'a ref; init: unit -> 'a } -> ref_and_reset + | Ref : { ref: 'a ref; mutable snapshot: 'a } -> ref_and_reset + +type bindings = { + mutable refs: ref_and_reset list; + mutable frozen : bool; + mutable is_bound: bool; +} + +let global_bindings = + { refs = []; is_bound = false; frozen = false } + +let is_bound () = global_bindings.is_bound + +let reset () = + assert (is_bound ()); + List.iter (function + | Table { ref; init } -> ref := init () + | Ref { ref; snapshot } -> ref := snapshot + ) global_bindings.refs + +let s_table create size = + let init () = create size in + let ref = ref (init ()) in + assert (not global_bindings.frozen); + global_bindings.refs <- (Table { ref; init }) :: global_bindings.refs; + ref + +let s_ref k = + let ref = ref k in + assert (not global_bindings.frozen); + global_bindings.refs <- + (Ref { ref; snapshot = k }) :: global_bindings.refs; + ref + +type slot = Slot : { ref : 'a ref; mutable value : 'a } -> slot +type store = slot list + +let fresh () = + let slots = + List.map (function + | Table { ref; init } -> Slot {ref; value = init ()} + | Ref r -> + if not global_bindings.frozen then r.snapshot <- !(r.ref); + Slot { ref = r.ref; value = r.snapshot } + ) global_bindings.refs + in + global_bindings.frozen <- true; + slots + +let with_store slots f = + assert (not global_bindings.is_bound); + global_bindings.is_bound <- true; + List.iter (fun (Slot {ref;value}) -> ref := value) slots; + Fun.protect f ~finally:(fun () -> + List.iter (fun (Slot s) -> s.value <- !(s.ref)) slots; + global_bindings.is_bound <- false; + ) diff --git a/utils/local_store.mli b/utils/local_store.mli new file mode 100644 index 000000000..f39cd1232 --- /dev/null +++ b/utils/local_store.mli @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Frederic Bour, Tarides *) +(* Thomas Refis, Tarides *) +(* *) +(* Copyright 2020 Tarides *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides some facilities for creating references (and hash + tables) which can easily be snapshoted and restored to an arbitrary version. + + It is used throughout the frontend (read: typechecker), to register all + (well, hopefully) the global state. Thus making it easy for tools like + Merlin to go back and forth typechecking different files. *) + +(** {1 Creators} *) + +val s_ref : 'a -> 'a ref +(** Similar to {!ref}, except the allocated reference is registered into the + store. *) + +val s_table : ('a -> 'b) -> 'a -> 'b ref +(** Used to register hash tables. Those also need to be placed into refs to be + easily swapped out, but one can't just "snapshot" the initial value to + create fresh instances, so instead an initializer is required. + + Use it like this: + {[ + let my_table = s_table Hashtbl.create 42 + ]} +*) + +(** {1 State management} + + Note: all the following functions are currently unused inside the compiler + codebase. Merlin is their only user at the moment. *) + +type store + +val fresh : unit -> store +(** Returns a fresh instance of the store. + + The first time this function is called, it snapshots the value of all the + registered references, later calls to [fresh] will return instances + initialized to those values. *) + +val with_store : store -> (unit -> 'a) -> 'a +(** [with_scope s f] resets all the registered references to the value they have + in [s] for the run of [f]. + If [f] updates any of the registered refs, [s] is updated to remember those + changes. *) + +val reset : unit -> unit +(** Resets all the references to the initial snapshot (i.e. to the same values + that new instances start with). *) + +val is_bound : unit -> bool +(** Returns [true] when a scope is active (i.e. when called from the callback + passed to {!with_scope}), [false] otherwise. *)