Fix Env.without_cmis (#1223)

* Fix Env.without_cmis

* Add regression test

* Add changes entry

7 files changed, 147 insertions, 43 deletions

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