Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Centralized tracking of frontend's global state (#9963) 

import Local_store from merlin, with a simplified API following review comments
master
Thomas Refis 2020-10-15 14:47:19 +02:00 committed by GitHub
parent 5410d0c5d3
commit 9fdc759ac0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
16 changed files with 265 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
.depend
View File

@ -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 \

3
Changes
View File

@ -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

3
compilerlibs/Makefile.compilerlibs
View File

@ -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 \

2
dune
View File

@ -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

1
otherlibs/dynlink/Makefile
View File

@ -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 \

4
tools/Makefile
View File

@ -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),)

20
typing/btype.ml
View File

@ -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

10
typing/ctype.ml
View File

@ -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;

104
typing/env.ml
View File

@ -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

6
typing/ident.ml
View File

@ -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;

4
typing/subst.ml
View File

@ -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 =

6
utils/config.mli
View File

@ -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
(**/**)

2
utils/config.mlp
View File

@ -237,3 +237,5 @@ let config_var x =
| Bool b -> string_of_bool b
in
Some s
let merlin = false

14
utils/load_path.ml
View File

@ -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

74
utils/local_store.ml Normal file
View File

@ -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;
)

66
utils/local_store.mli Normal file
View File

@ -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. *)