flambda-backend: Backport 13099 (#2529)

* Add regression test (with exn-raising output)

* Fix bug by backporting 13099

* push a small difference to upstream

* apology

Author: ncik-roberts

testsuite/tests/typing-modules/pr13099/lib1/lib.ml

@@ -0,0 +1 @@
+type t = unit

testsuite/tests/typing-modules/pr13099/lib1_client.ml

@@ -0,0 +1 @@
+let f (_ : Lib.t) = ()

testsuite/tests/typing-modules/pr13099/lib2/lib.ml

@@ -0,0 +1 @@
+type t = bool

testsuite/tests/typing-modules/pr13099/lib2_client.ml

@@ -0,0 +1,19 @@
+let f (_ : Lib.t) = ()
+
+(* The naming of this module is important: When the error reporting
+   is running in a mode where it can load new cmis from disk, this
+   module leads the compiler to try to load a cmi file [lib1_client.cmi].
+   That's because the compiler tries to be smart about double-underscore
+   paths, rewriting [Foo__Bar] to [Foo.Bar] when these names are aliases.
+ *)
+module Lib1_client__X = struct
+  type t = A
+end
+
+module F (T : sig type t end) = struct
+  type t = Lib1_client__X.t
+
+  let f (_ : T.t) = ()
+end
+
+module _ = F (struct type t = T end)

testsuite/tests/typing-modules/pr13099/test.compilers.reference

@@ -0,0 +1,8 @@
+File "lib2_client.ml", line 19, characters 11-36:
+19 | module _ = F (struct type t = T end)
+                ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This functor has type
+       functor (T : sig type t end) ->
+         sig type t = Lib1_client__X.t val f : T.t -> unit end
+       The parameter cannot be eliminated in the result type.
+       Please bind the argument to a module identifier.

testsuite/tests/typing-modules/pr13099/test.ml

@@ -0,0 +1,33 @@
+(* TEST
+ subdirectories = "lib1 lib2";
+ readonly_files = "lib1_client.ml lib2_client.ml";
+ compile_only = "true";
+ setup-ocamlopt.byte-build-env;
+
+ (* Set up the Lib modules that the client modules depend on *)
+ all_modules = "lib1/lib.ml";
+ ocamlopt.byte;
+ all_modules = "lib2/lib.ml";
+ ocamlopt.byte;
+
+ (* Compile Lib1_client against Lib1 *)
+ flags = "-I lib1";
+ all_modules = "lib1_client.ml";
+ ocamlopt.byte;
+
+ (* Compile Lib2_client against Lib2 *)
+ flags = "-I lib2";
+ all_modules = "lib2_client.ml";
+ ocamlopt_byte_exit_status = "2";
+ ocamlopt.byte;
+ check-ocamlopt.byte-output;
+*)
+
+(* This test is a regression test. The bug was in the last step: the compiler crashed
+   with an exception and backtrace instead of printing a useful error message. The
+   issue was that the compiler was erroneously running in a mode where its error reporting
+   is allowed to load cmi files from disk. This mode is undesirable because it means
+   that the compiler can encounter new exceptions (e.g. that the new cmi file it loads
+   is not consistent with other cmi files) while doing error reporting for the old
+   exception.
+ *)

typing/printtyp.ml

@@ -843,6 +843,20 @@ let wrap_printing_env ~error env f =
   if error then Env.without_cmis (wrap_printing_env env) f
   else wrap_printing_env env f
 
+let wrap_printing_env_error env f =
+  let wrap (loc : _ Location.loc) =
+    { loc with txt =
+        (fun fmt -> Env.without_cmis (fun () -> loc.txt fmt) ())
+  (* CR nroberts: See https://github.com/ocaml-flambda/flambda-backend/pull/2529
+     for an explanation of why this has drifted from upstream. *)
+    }
+  in
+  let err : Location.error = wrap_printing_env ~error:true env f in
+  { Location.kind = err.kind;
+    main = wrap err.main;
+    sub = List.map wrap err.sub;
+  }
+
 let rec lid_of_path = function
     Path.Pident id ->
       Longident.Lident (Ident.name id)

typing/printtyp.mli

@@ -50,6 +50,14 @@ val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a
     (* This affects all the printing functions below *)
     (* Also, if [~error:true], then disable the loading of cmis *)
 
+(** [wrap_printing_env_error env f] ensures that all printing functions in a
+    [Location.error] report are evaluated within the [wrap_printing_env
+    ~error:true env] context. (The original call to [f] is also evaluated
+    within that context.)
+*)
+val wrap_printing_env_error :
+  Env.t -> (unit -> Location.error) -> Location.error
+
 module Naming_context: sig
   val enable: bool -> unit
   (** When contextual names are enabled, the mapping between identifiers

typing/typecore.ml

@@ -10255,7 +10255,7 @@ let report_error ~loc env = function
          automatically if ommitted. It cannot be passed with '?'.@]" label
 
 let report_error ~loc env err =
-  Printtyp.wrap_printing_env ~error:true env
+  Printtyp.wrap_printing_env_error env
     (fun () -> report_error ~loc env err)
 
 let () =

typing/typemod.ml

@@ -3869,7 +3869,7 @@ let report_error ~loc _env = function
         "Cannot compile an implementation with -as-parameter."
 
 let report_error env ~loc err =
-  Printtyp.wrap_printing_env ~error:true env
+  Printtyp.wrap_printing_env_error env
     (fun () -> report_error env ~loc err)
 
 let () =