From 44ffed47542fea236f123e3be4eab718baa4c8c2 Mon Sep 17 00:00:00 2001 From: Leo White Date: Wed, 19 Jul 2017 09:01:29 +0100 Subject: Fix Env.without_cmis (#1223) * Fix Env.without_cmis * Add regression test * Add changes entry --- Changes | 4 + testsuite/tests/typing-short-paths/Makefile | 4 + testsuite/tests/typing-short-paths/gpr1223.ml | 4 + .../tests/typing-short-paths/gpr1223.ml.reference | 4 + testsuite/tests/typing-short-paths/gpr1223_bar.mli | 12 ++ testsuite/tests/typing-short-paths/gpr1223_foo.mli | 6 + typing/env.ml | 156 +++++++++++++++------ 7 files changed, 147 insertions(+), 43 deletions(-) create mode 100644 testsuite/tests/typing-short-paths/gpr1223.ml create mode 100644 testsuite/tests/typing-short-paths/gpr1223.ml.reference create mode 100644 testsuite/tests/typing-short-paths/gpr1223_bar.mli create mode 100644 testsuite/tests/typing-short-paths/gpr1223_foo.mli diff --git a/Changes b/Changes index 1429507ce0..8cf436104e 100644 --- a/Changes +++ b/Changes @@ -279,6 +279,10 @@ Working version created by Unix.symlink under Windows. (Nicolas Ojeda Bar, review by David Allsopp) +- GPR#1223: Fix corruption of the environment when using -short-paths + with the toplevel. + (Leo White, review by Alain Frisch) + - Fix pprintast for #... infix operators (Alain Frisch, report by Omar Chebib) diff --git a/testsuite/tests/typing-short-paths/Makefile b/testsuite/tests/typing-short-paths/Makefile index 3e5a5df040..10856782bd 100644 --- a/testsuite/tests/typing-short-paths/Makefile +++ b/testsuite/tests/typing-short-paths/Makefile @@ -17,3 +17,7 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common TOPFLAGS = -short-paths + +default: gpr1223_foo.cmi gpr1223_bar.cmi + +gpr1223_bar.cmi: gpr1223_foo.cmi diff --git a/testsuite/tests/typing-short-paths/gpr1223.ml b/testsuite/tests/typing-short-paths/gpr1223.ml new file mode 100644 index 0000000000..0c481dbb5b --- /dev/null +++ b/testsuite/tests/typing-short-paths/gpr1223.ml @@ -0,0 +1,4 @@ + +let y = Gpr1223_bar.N.O.T;; + +let x = Gpr1223_bar.M.T;; diff --git a/testsuite/tests/typing-short-paths/gpr1223.ml.reference b/testsuite/tests/typing-short-paths/gpr1223.ml.reference new file mode 100644 index 0000000000..cf578cdb3b --- /dev/null +++ b/testsuite/tests/typing-short-paths/gpr1223.ml.reference @@ -0,0 +1,4 @@ + +# val y : Gpr1223_bar.N.O.t = Gpr1223_bar.N.O.T +# val x : Gpr1223_bar.M.t = Gpr1223_bar.M.T +# diff --git a/testsuite/tests/typing-short-paths/gpr1223_bar.mli b/testsuite/tests/typing-short-paths/gpr1223_bar.mli new file mode 100644 index 0000000000..f3f51e0906 --- /dev/null +++ b/testsuite/tests/typing-short-paths/gpr1223_bar.mli @@ -0,0 +1,12 @@ + +module M : Gpr1223_foo.S + +module N : sig + + module O : sig + + type t = T + + end + +end diff --git a/testsuite/tests/typing-short-paths/gpr1223_foo.mli b/testsuite/tests/typing-short-paths/gpr1223_foo.mli new file mode 100644 index 0000000000..b46079d7fb --- /dev/null +++ b/testsuite/tests/typing-short-paths/gpr1223_foo.mli @@ -0,0 +1,6 @@ + +module type S = sig + + type t = T + +end diff --git a/typing/env.ml b/typing/env.ml index d16e1e721a..a1105fab89 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -72,31 +72,46 @@ let error err = raise (Error err) module EnvLazy : sig type ('a,'b) t + type log + val force : ('a -> 'b) -> ('a,'b) t -> 'b val create : 'a -> ('a,'b) t val get_arg : ('a,'b) t -> 'a option + (* [force_logged log f t] is equivalent to [force f t] but if [f] returns [None] then + [t] is recorded in [log]. [backtrack log] will then reset all the recorded [t]s back + to their original state. *) + val log : unit -> log + val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option + val backtrack : log -> unit + end = struct type ('a,'b) t = ('a,'b) eval ref and ('a,'b) eval = - Done of 'b + | Done of 'b | Raise of exn | Thunk of 'a + type undo = + | Nil + | Cons : ('a, 'b) t * 'a * undo -> undo + + type log = undo ref + let force f x = match !x with - Done x -> x - | Raise e -> raise e - | Thunk e -> - try - let y = f e in - x := Done y; - y - with e -> - x := Raise e; - raise e + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e let get_arg x = match !x with Thunk a -> Some a | _ -> None @@ -104,6 +119,35 @@ end = struct let create x = ref (Thunk x) + let log () = + ref Nil + + let force_logged log f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | None -> + x := Done None; + log := Cons(x, e, !log); + None + | Some _ as y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e + + let backtrack log = + let rec loop = function + | Nil -> () + | Cons(x, e, rest) -> + x := Thunk e; + loop rest + in + loop !log + end module PathMap = Map.Make(Path) @@ -417,8 +461,9 @@ and module_components = { deprecated: string option; loc: Location.t; - comps: (t * Subst.t * Path.t * Types.module_type, module_components_repr) - EnvLazy.t; + comps: + (t * Subst.t * Path.t * Types.module_type, module_components_repr option) + EnvLazy.t; } and module_components_repr = @@ -523,6 +568,22 @@ let diff env1 env2 = IdTbl.diff_keys env1.modules env2.modules @ IdTbl.diff_keys env1.classes env2.classes +type can_load_cmis = + | Can_load_cmis + | Cannot_load_cmis of EnvLazy.log + +let can_load_cmis = ref Can_load_cmis + +let without_cmis f x = + let log = EnvLazy.log () in + let res = + Misc.(protect_refs + [R (can_load_cmis, Cannot_load_cmis log)] + (fun () -> f x)) + in + EnvLazy.backtrack log; + res + (* Forward declarations *) let components_of_module' = @@ -532,7 +593,7 @@ let components_of_module' = module_components) let components_of_module_maker' = ref ((fun (_env, _sub, _path, _mty) -> assert false) : - t * Subst.t * Path.t * module_type -> module_components_repr) + t * Subst.t * Path.t * module_type -> module_components_repr option) let components_of_functor_appl' = ref ((fun _f _env _p1 _p2 -> assert false) : functor_components -> t -> Path.t -> Path.t -> module_components) @@ -548,9 +609,27 @@ let strengthen = let md md_type = {md_type; md_attributes=[]; md_loc=Location.none} -let get_components c = - EnvLazy.force !components_of_module_maker' c.comps +let get_components_opt c = + match !can_load_cmis with + | Can_load_cmis -> + EnvLazy.force !components_of_module_maker' c.comps + | Cannot_load_cmis log -> + EnvLazy.force_logged log !components_of_module_maker' c.comps + +let empty_structure = + Structure_comps { + comp_values = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; + comp_types = Tbl.empty; + comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; + comp_components = Tbl.empty; comp_classes = Tbl.empty; + comp_cltypes = Tbl.empty } +let get_components c = + match get_components_opt c with + | None -> empty_structure + | Some c -> c (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) @@ -678,25 +757,24 @@ let read_pers_struct check modname filename = acknowledge_pers_struct check modname { Persistent_signature.filename; cmi } -let can_load_cmis = ref true -let without_cmis f x = - Misc.(protect_refs [R (can_load_cmis, false)] (fun () -> f x)) - let find_pers_struct check name = if name = "*predef*" then raise Not_found; match Hashtbl.find persistent_structures name with | Some ps -> ps | None -> raise Not_found - | exception Not_found when !can_load_cmis -> - let ps = - match !Persistent_signature.load ~unit_name:name with - | Some ps -> ps - | None -> - Hashtbl.add persistent_structures name None; - raise Not_found - in - add_import name; - acknowledge_pers_struct check name ps + | exception Not_found -> + match !can_load_cmis with + | Cannot_load_cmis _ -> raise Not_found + | Can_load_cmis -> + let ps = + match !Persistent_signature.load ~unit_name:name with + | Some ps -> ps + | None -> + Hashtbl.add persistent_structures name None; + raise Not_found + in + add_import name; + acknowledge_pers_struct check name ps (* Emits a warning if there is no valid cmi for name *) let check_pers_struct name = @@ -1591,7 +1669,7 @@ let rec components_of_module ~deprecated ~loc env sub path mty = } and components_of_module_maker (env, sub, path, mty) = - (match scrape_alias env mty with + match scrape_alias env mty with Mty_signature sg -> let c = { comp_values = Tbl.empty; @@ -1669,26 +1747,18 @@ and components_of_module_maker (env, sub, path, mty) = c.comp_cltypes <- Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) sg pl; - Structure_comps c + Some (Structure_comps c) | Mty_functor(param, ty_arg, ty_res) -> - Functor_comps { + Some (Functor_comps { fcomp_param = param; (* fcomp_arg and fcomp_res must be prefixed eagerly, because they are interpreted in the outer environment *) fcomp_arg = may_map (Subst.modtype sub) ty_arg; fcomp_res = Subst.modtype sub ty_res; fcomp_cache = Hashtbl.create 17; - fcomp_subst_cache = Hashtbl.create 17 } + fcomp_subst_cache = Hashtbl.create 17 }) | Mty_ident _ - | Mty_alias _ -> - Structure_comps { - comp_values = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; - comp_types = Tbl.empty; - comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; - comp_components = Tbl.empty; comp_classes = Tbl.empty; - comp_cltypes = Tbl.empty }) + | Mty_alias _ -> None (* Insertion of bindings by identifier + path *) -- cgit v1.2.1