Merge pull request #10712 from NathanReb/fix-type-var-naming

Name expressions after typing in ocamlnat (restores equivalence with bytecode toplevel)

.depend

@@ -6606,7 +6606,6 @@ toplevel/native/topeval.cmo : \
     middle_end/compilenv.cmi \
     utils/clflags.cmi \
     parsing/asttypes.cmi \
-    parsing/ast_helper.cmi \
     asmcomp/asmlink.cmi \
     toplevel/native/topeval.cmi
 toplevel/native/topeval.cmx : \
@@ -6638,7 +6637,6 @@ toplevel/native/topeval.cmx : \
     middle_end/compilenv.cmx \
     utils/clflags.cmx \
     parsing/asttypes.cmi \
-    parsing/ast_helper.cmx \
     asmcomp/asmlink.cmx \
     toplevel/native/topeval.cmi
 toplevel/native/topeval.cmi : \

Changes

@@ -435,6 +435,11 @@ OCaml 4.14.0
   implementation of stat
   (Antonin Décimo, review by David Allsopp)
 
+- #10712: Type-check toplevel terms in the native toplevel in the same way as
+  the bytecode toplevel. In particular, this fixes the loss of type variable
+  names in the native toplevel.
+  (Leo White, review by David Allsopp and Gabriel Scherer)
+
 - #10735: Uncaught unify exception from `build_as_type`
   (Jacques Garrigue, report and review by Leo White)
 

ocamltest/ocaml_tests.ml

@@ -67,11 +67,18 @@ let toplevel = {
     setup_ocaml_build_env;
     ocaml;
     check_ocaml_output;
-(*
+  ]
+}
+
+let nattoplevel = {
+  test_name = "toplevel.opt";
+  test_run_by_default = false;
+  test_actions =
+  [
+    shared_libraries;
     setup_ocamlnat_build_env;
     ocamlnat;
     check_ocamlnat_output;
-*)
   ]
 }
 
@@ -135,6 +142,7 @@ let _ =
     bytecode;
     native;
     toplevel;
+    nattoplevel;
     expect;
     ocamldoc;
     asmgen;

testsuite/tests/tool-toplevel/pr10712.compilers.reference

@@ -0,0 +1,5 @@
+module A :
+  sig type ('foo, 'bar) t val get_foo : ('foo, 'a) t -> 'foo option end
+- : ('foo, 'a) A.t -> 'foo option = <fun>
+val _bar : ('a, 'b) A.t -> 'a option = <fun>
+

testsuite/tests/tool-toplevel/pr10712.ml

@@ -0,0 +1,27 @@
+(* TEST
+   * toplevel
+   * toplevel.opt
+*)
+
+module A : sig
+  type ('foo, 'bar) t
+
+  val get_foo : ('foo, _) t -> 'foo option
+end = struct
+  type ('foo, 'bar) t =
+    | Foo of 'foo
+    | Bar of 'bar
+
+  let get_foo = function
+    | Foo foo -> Some foo
+    | Bar _ -> None
+end
+;;
+
+(* Type variables should be 'foo and 'a (name persists) *)
+A.get_foo
+;;
+
+(* Type variables be 'a and 'b (original names lost in let-binding) *)
+let _bar = A.get_foo
+;;

toplevel/native/topeval.ml

@@ -115,6 +115,44 @@ let pr_item =
 
 let phrase_seqid = ref 0
 
+let name_expression ~loc ~attrs exp =
+  let name = "_$" in
+  let id = Ident.create_local name in
+  let vd =
+    { val_type = exp.exp_type;
+      val_kind = Val_reg;
+      val_loc = loc;
+      val_attributes = attrs;
+      val_uid = Uid.internal_not_actually_unique; }
+   in
+   let sg = [Sig_value(id, vd, Exported)] in
+   let pat =
+     { pat_desc = Tpat_var(id, mknoloc name);
+       pat_loc = loc;
+       pat_extra = [];
+       pat_type = exp.exp_type;
+       pat_env = exp.exp_env;
+       pat_attributes = []; }
+   in
+   let vb =
+     { vb_pat = pat;
+       vb_expr = exp;
+       vb_attributes = attrs;
+       vb_loc = loc; }
+   in
+   let item =
+     { str_desc = Tstr_value(Nonrecursive, [vb]);
+       str_loc = loc;
+       str_env = exp.exp_env; }
+   in
+   let final_env = Env.add_value id vd exp.exp_env in
+   let str =
+     { str_items = [item];
+       str_type = sg;
+       str_final_env = final_env }
+   in
+   str, sg
+
 let execute_phrase print_outcome ppf phr =
   match phr with
   | Ptop_def sstr ->
@@ -123,21 +161,6 @@ let execute_phrase print_outcome ppf phr =
       let phrase_name = "TOP" ^ string_of_int !phrase_seqid in
       Compilenv.reset ?packname:None phrase_name;
       Typecore.reset_delayed_checks ();
-      let sstr, rewritten =
-        match sstr with
-        | [ { pstr_desc = Pstr_eval (e, attrs) ; pstr_loc = loc } ]
-        | [ { pstr_desc = Pstr_value (Asttypes.Nonrecursive,
-                                      [{ pvb_expr = e
-                                       ; pvb_pat = { ppat_desc = Ppat_any ; _ }
-                                       ; pvb_attributes = attrs
-                                       ; _ }])
-            ; pstr_loc = loc }
-          ] ->
-            let pat = Ast_helper.Pat.var (Location.mknoloc "_$") in
-            let vb = Ast_helper.Vb.mk ~loc ~attrs pat e in
-            [ Ast_helper.Str.value ~loc Asttypes.Nonrecursive [vb] ], true
-        | _ -> sstr, false
-      in
       let (str, sg, names, shape, newenv) =
         Typemod.type_toplevel_phrase oldenv sstr
       in
@@ -146,6 +169,34 @@ let execute_phrase print_outcome ppf phr =
       let sg' = Typemod.Signature_names.simplify newenv names sg in
       ignore (Includemod.signatures oldenv ~mark:Mark_positive sg sg');
       Typecore.force_delayed_checks ();
+      (* `let _ = <expression>` or even just `<expression>` require special
+         handling in toplevels, or nothing is displayed. In bytecode, the
+         lambda for <expression> is directly executed and the result _is_ the
+         value. In native, the lambda for <expression> is compiled and loaded
+         from a DLL, and the result of loading that DLL is _not_ the value
+         itself. In native, <expression> must therefore be named so that it can
+         be looked up after the DLL has been dlopen'd.
+
+         The expression is "named" after typing in order to ensure that both
+         bytecode and native toplevels always type-check _exactly_ the same
+         expression. Adding the binding at the parsetree level (before typing)
+         can create observable differences (e.g. in type variable names, see
+         tool-toplevel/pr10712.ml in the testsuite) *)
+      let str, sg', rewritten =
+         match str.str_items with
+         | [ { str_desc = Tstr_eval (e, attrs) ; str_loc = loc } ]
+         | [ { str_desc = Tstr_value (Asttypes.Nonrecursive,
+                                       [{ vb_expr = e
+                                        ; vb_pat =
+                                            { pat_desc = Tpat_any;
+                                              pat_extra = []; _ }
+                                        ; vb_attributes = attrs }])
+             ; str_loc = loc }
+           ] ->
+             let str, sg' = name_expression ~loc ~attrs e in
+             str, sg', true
+         | _ -> str, sg', false
+      in
       let module_ident, res, required_globals, size =
         if Config.flambda then
           let { Lambda.module_ident; main_module_block_size = size;